Source module last modified on Mon, 23 May 2005, 17:53;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#---------------------------------------------------------------
logical FUNCTION TAS1_GO2()
# trace primary TAS spectrometer from the source
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,CRYST_GO2,SOURCE_GO
logical log ! ,SAM_BOARDER
# REAL*8 T1,T2
common /neuif/ neui,neuf,neui1,neuf1
log=.true.
# LOG=SAM_BOARDER(SAM,NEUI.R,NEUI.K,T1,T2)
neui1=neui
# LOG=(LOG.AND.NEUI1.P.GT.0)
if(log) log=(log.and.SOURCE_GO(sou,neui1,neu1))
if(log) log=(log.and.BENDER_GO(gdea,neu1,neu))
if(log) log=(log.and.BENDER_GO(guide,neu,neu1))
if(log) log=(log.and.BENDER_GO(sol1,neu1,neu))
if(log) log=(log.and.CRYST_GO2(mon,neu,neu1))
if (mon.nh.eq.0) then
neui=neu1
TAS1_GO2=log
return
endif
if(log) log=(log.and.BENDER_GO(sol2a,neu1,neu))
if(log) log=(log.and.BENDER_GO(sol2,neu,neui))
if(flipm.eq.1) neui.s=-neui.s
TAS1_GO2=log
end
#---------------------------------------------------------------
logical FUNCTION FLUX_GO2()
# simulate incident flux, start at the source
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu
logical SLIT_GO,TAS1_GO2
logical log
common /neuif/ neui,neuf,neui1,neuf1
log= TAS1_GO2()
if (mon.nh.eq.0) then
FLUX_GO2=log
return
endif
neu=neui
if(log) log=(log.and.SLIT_GO(sam,neu,neui))
FLUX_GO2=log
end
#---------------------------------------------------------------
logical FUNCTION DIFF_GO2()
# trace from the source to the detector with pwd. sample
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,SLIT_GO,TAS1_GO2,PWD_GO
logical log
common /neuif/ neui,neuf,neui1,neuf1
log=TAS1_GO2()
if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss))
neu1=neuf
if(flipa.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
if(log) log=(log.and.SLIT_GO(det,neu,neuf1))
DIFF_GO2=log
end
#---------------------------------------------------------------
logical FUNCTION MONIT_GO2()
# trace from the source to the monitor at position IMONIT
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,SLIT_GO,CRYST_GO2,SOURCE_GO,VAN_GO,VAN_TRANS
logical log
integer*4 m
real*8 ll,k0
integer*4 i
common /neuif/ neui,neuf,neui1,neuf1
log=.true.
neui1=neui
log=(neui1.p.gt.0)
m=imonit
if(log) log=(log.and.SOURCE_GO(sou,neui1,neu1))
if (m.eq.0) goto 101
if(log) log=(log.and.BENDER_GO(gdea,neu1,neu))
if (m.eq.1) goto 100
if(log) log=(log.and.BENDER_GO(guide,neu,neu1))
if (m.eq.2) goto 101
if(log) log=(log.and.BENDER_GO(sol1,neu1,neu))
if (m.eq.3) goto 100
if (.not.log) goto 111
if(log) log=(log.and.CRYST_GO2(mon,neu,neu1))
if (m.eq.4) goto 101
if(log) log=(log.and.BENDER_GO(sol2a,neu1,neu))
if (m.eq.5) goto 100
if(log) log=(log.and.BENDER_GO(sol2,neu,neui))
if (m.eq.6) then
neu1=neui
goto 101
endif
if(flipm.eq.1) neui.s=-neui.s
if(m.eq.7) then
if(log) log=(log.and.VAN_TRANS(sam,neui,neuf))
ll=(sol3.frame.dist-neuf.r(3))
do i=1,2
neuf.r(i)=neuf.r(i)+ll*neuf.k(i)/neuf.k(3)
enddo
neu=neuf
goto 100
endif
if (.not.log) goto 111
if(log) log=(log.and.VAN_GO(sam,neui,neuf,stp.q*stp.ss))
neu1=neuf
if(flipa.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
if (m.eq.8) goto 100
if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))
if (m.eq.9) goto 101
if (log) log=(log.and.BENDER_GO(sol4,neu1,neu))
if (m.eq.10) goto 100
if(log) log=(log.and.SLIT_GO(det,neu,neuf1))
MONIT_GO2=.true.
return
100 neuf1=neu
if (normmon.ne.0) then ! calculate capture flux
k0=sqrt(neuf1.k(1)**2+neuf1.k(2)**2+neuf1.k(3)**2)
neuf1.p=neuf1.p*2*pi/k0/1.8d0
endif
MONIT_GO2=log
return
101 neuf1=neu1
if (normmon.ne.0) then ! calculate capture flux
k0=sqrt(neuf1.k(1)**2+neuf1.k(2)**2+neuf1.k(3)**2)
neuf1.p=neuf1.p*2*pi/k0/1.8d0
endif
MONIT_GO2=log
return
111 MONIT_GO2=.false.
end
#--------------------------------------------------------
SUBROUTINE WrtNEU(neu)
INCLUDE 'structures.inc'
record /NEUTRON/ neu
1 format(7(1x,g10.4))
write(*,1) (neu.r(i),i=1,3),(neu.k(i),i=1,3),neu.p
end
#--------------------------------------------------------
SUBROUTINE FORW_INI(itask)
# Clears all necessary variables and, if ICLR<>1,
# initializes objects and limits of random variables
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'randvars.inc'
INCLUDE 'source.inc'
integer*4 itask,nev
logical*4 verbose
common /mcsetting/ verbose,nev
real*8 lzm,lms,z0,z1,z2,w1,h1,ctm,stb,eps,eps1,stpch,b
real*8 avmin,a1,a2,a3,a4,ahmin
integer*4 i,j
#/// revert primary spectrometer for the forward tracing:
#/// NESS_CONV and SPEC_INI must be allways called before !!
z1=sou.dist+sol1.frame.dist+guide.frame.dist+gdea.frame.dist
z2=mon.frame.dist+sol2.frame.dist+sol2a.frame.dist
sam.dist=sol2.frame.dist+sol2.frame.size(3)
sol2a.frame.dist=z2-sol2.frame.dist-
1 sol2a.frame.dist-sol2a.frame.size(3)
sol2.frame.dist=z2-sam.dist-sol2a.frame.dist
w1=sol2.frame.size(1)
h1=sol2.frame.size(2)
sol2.frame.size(1)=sol2.w2
sol2.frame.size(2)=sol2.h2
sol2.w2=w1
sol2.h2=h1
sol2.frame.axi=0
if (sol2.typ.le.1) sol2.ch=-sol2.ch
w1=sol2a.frame.size(1)
h1=sol2a.frame.size(2)
sol2a.frame.size(1)=sol2a.w2
sol2a.frame.size(2)=sol2a.h2
sol2a.w2=w1
sol2a.h2=h1
sol2a.frame.axi=-sol1.frame.axi
if (sol2a.typ.le.1) sol2a.ch=-sol2a.ch
mon.frame.dist=sol1.frame.dist+sol1.frame.size(3)
mon.frame.gon(1)=-mon.frame.gon(1) -2*mon.chi
gdea.frame.dist=z1-sol1.frame.dist-guide.frame.dist-
1 gdea.frame.dist-gdea.frame.size(3)
w1=gdea.frame.size(1)
h1=gdea.frame.size(2)
gdea.frame.size(1)=gdea.w2
gdea.frame.size(2)=gdea.h2
gdea.w2=w1
gdea.h2=h1
if (gdea.typ.le.1) gdea.ch=-gdea.ch
z1=z1-gdea.frame.dist
guide.frame.dist=z1-sol1.frame.dist-guide.frame.dist
1 -guide.frame.size(3)
w1=guide.frame.size(1)
h1=guide.frame.size(2)
guide.frame.size(1)=guide.w2
guide.frame.size(2)=guide.h2
guide.w2=w1
guide.h2=h1
if (guide.typ.le.1) guide.ch=-guide.ch
z1=z1-guide.frame.dist
sol1.frame.dist=z1-sol1.frame.dist-sol1.frame.size(3)
w1=sol1.frame.size(1)
h1=sol1.frame.size(2)
sol1.frame.size(1)=sol1.w2
sol1.frame.size(2)=sol1.h2
sol1.w2=w1
sol1.h2=h1
sol1.frame.axi=0
if (sol1.typ.le.1) sol1.ch=-sol1.ch
sou.dist=0
call SLIT_INIT(sou)
call BENDER_INIT(gdea)
call BENDER_INIT(guide)
call BENDER_INIT(sol1)
call CRYST_INIT2(mon)
call BENDER_INIT(sol2a)
call BENDER_INIT(sol2)
call SLIT_INIT(sam)
lzm=sol1.frame.dist+mon.frame.dist+guide.frame.dist+
1 gdea.frame.dist
lms=sol2.frame.dist+sol2a.frame.dist+sam.dist
ctm=sign(1,stp.sm)/tan(mon.thb)
stb=sin(mon.thb)
eps1=1-2*mon.rv*abs(stb)*lms
#//// minimum vertical aperture:
avmin=1.d+35
if (guide.frame.size(3).gt.0.and.guide.frame.dist.gt.0) then
a1=(sou.size(2)+guide.frame.size(2))/
1 (guide.frame.dist+gdea.frame.dist)
a2=(guide.h2+guide.frame.size(2))/guide.frame.size(3)/guide.nlv
a3=guide.gvt*4*pi/stp.ki
a4=abs((guide.frame.size(2)+mon.frame.size(2))/
1 (lzm-guide.frame.dist-gdea.frame.dist))
avmin=min(avmin,a1,max(a2,a3),max(a3,a4))
endif
if (guide.gvt.eq.0.d+0.and.
1 sol1.frame.size(3).gt.0.and.sol1.frame.dist.gt.0) then
a1=(sou.size(2)+sol1.frame.size(2))/
1 (guide.frame.dist+sol1.frame.dist+gdea.frame.dist)
a2=(sol1.h2+sol1.frame.size(2))/sol1.frame.size(3)/sol1.nlv
a3=sol1.gvt*4*pi/stp.ki
a4=abs((sol1.frame.size(2)+mon.frame.size(2))/
1 (lzm-guide.frame.dist-sol1.frame.dist-gdea.frame.dist))
avmin=min(avmin,a1,max(a2,a3),max(a3,a4))
endif
if (sol1.gvt.eq.0.d+0.and.guide.gvt.eq.0.d+0) then
avmin=min(avmin,(sou.size(2)+mon.frame.size(2)*stb)/lzm)
endif
#//// minimum horizontal aperture:
ahmin=1.d+35
if (guide.frame.size(3).gt.0.and.guide.frame.dist.gt.0) then
a1=(sou.size(1)+guide.frame.size(1))/
1 (guide.frame.dist+gdea.frame.dist)
a2=(guide.w2+guide.frame.size(1))/guide.frame.size(3)/guide.nlh
a3=guide.ghlu*4*pi/stp.ki
a4=abs((guide.frame.size(1)+mon.frame.size(1)*stb)/
1 (lzm-guide.frame.dist-gdea.frame.dist))
ahmin=min(ahmin,a1,max(a2,a3),max(a3,a4))
endif
if (guide.ghlu.eq.0.d+0.and.
1 sol1.frame.size(3).gt.0.and.sol1.frame.dist.gt.0) then
a1=(sou.size(1)+sol1.frame.size(1))/
1 (sol1.frame.dist+guide.frame.dist+gdea.frame.dist)
a2=(sol1.w2+sol1.frame.size(1))/sol1.frame.size(3)/sol1.nlh
a3=sol1.ghlu*4*pi/stp.ki
a4=abs((sol1.frame.size(1)+mon.frame.size(1)*stb)/
1 (lzm-guide.frame.dist-sol1.frame.dist-gdea.frame.dist))
ahmin=min(ahmin,a1,max(a2,a3),max(a3,a4))
endif
if (sol1.ghlu.eq.0.d+0.and.guide.ghlu.eq.0.d+0) then
ahmin=min(ahmin,(sou.size(1)+mon.frame.size(1)*stb)/lzm)
endif
#// common constraints for simulation started at the source
tmat(5,2)=-eps1/(lzm*eps1+lms)
tmat(2,5)=0
rndlist.limits(2)=
1 min(avmin,sam.size(2)/(lms+lzm)+abs(3*mon.vmos*stb))
rndlist.limits(5)=sou.size(2)
#!! New horizontal optimization - 28/1/2000 !!!
stpch=sin(mon.thb+mon.chi)
eps=stpch/mon.stmch
b=eps-2*mon.rh*lms/mon.stmch
rndlist.limits(1)=abs(ahmin)*rndlist.pool(1)
tmat(4,3)=-mon.rh*stp.ki/mon.stmch*ctm
tmat(1,3)=(1-lzm*mon.rh/mon.stmch)*ctm*stp.ki
rndlist.limits(3)=sqrt((4*mon.hmos)**2+(mon.rh*
1 mon.frame.size(3)*mon.ctmch/mon.stmch)**2)*stp.ki*abs(ctm)
rndlist.limits(4)=sou.size(1)*rndlist.pool(4)
#// Only primary beamline, without monochromator
if (mon.nh.eq.0.or.
* (itask.eq.7.and.imonit.ge.0.and.imonit.lt.4)) then
rndlist.limits(1)=ahmin
rndlist.limits(2)=avmin
rndlist.limits(4)=sou.size(1)
rndlist.limits(5)=sou.size(2)
rndlist.active(3)=0
if (flxn.gt.0) then
z0=2*pi/flxlam(1)
z1=2*pi/flxlam(flxn)
tmean(3)=(z1+z0)/2
rndlist.limits(3)=abs(z1-z0)
rndlist.active(3)=1
else
rndlist.limits(3)=0.01*stp.ki
endif
if (flxh.gt.0) then
rndlist.active(1)=0
rndlist.limits(1)=flxh*1.2
endif
if (flxv.gt.0) then
rndlist.active(2)=0
rndlist.limits(2)=flxv*1.2
endif
do i=1,6
do j=1,6
if (i.ne.j) then
tmat(i,j)=0.
else
tmat(i,j)=1.
endif
enddo
enddo
endif
#// if divergence limits for source were given in options:
if (flxh.gt.0) rndlist.limits(1)=flxh*1.2
if (flxv.gt.0) rndlist.limits(2)=flxv*1.2
#// no constraints in debug mode
if (idbg.ge.1) then
if (flxh.le.0) rndlist.limits(1)=ahmin
if (flxv.le.0) rndlist.limits(2)=avmin
if (flxn.le.0) rndlist.limits(3)=0.05*stp.ki
rndlist.limits(4)=sou.size(1)
rndlist.limits(5)=sou.size(2)
endif
if (verbose) write(*,*) 'Forward tracing (source -> sample)'
end