Source module last modified on Mon, 23 May 2005, 12:50;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#//// ////
#//// NEutron Scattering Simulation - v.2.0, (c) J.Saroun, 2000 ////
#//// ////
#//////////////////////////////////////////////////////////////////////
#////
#//// Subroutines describing objects - SOURCE
#////
#////
#//////////////////////////////////////////////////////////////////////
#-------------------------------------------------
logical*4 FUNCTION SOURCE_GO(obj,neui,neuf)
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
INCLUDE 'source.inc'
logical*4 log1, SLIT_GO
real*8 k0,a,DFLUX
record /SLIT/ obj
record /NEUTRON/ neui,neuf
1 format(a10,1x,i4,1x,7(g11.4))
log1=SLIT_GO(obj,neui,neuf)
if (log1) then
k0=sqrt(neuf.k(1)**2+neuf.k(2)**2+neuf.k(3)**2)
neuf.p=neuf.p*DFLUX(neuf.r,neuf.k)
if (flxh.gt.0) then
a=atan(neuf.k(1)/neuf.k(3))
if (abs(a).gt.flxh/2.) neuf.p=0
endif
if (neuf.p.gt.0.and.flxv.gt.0) then
a=atan(neuf.k(2)/neuf.k(3))
if (abs(a).gt.flxv/2.) neuf.p=0
endif
if (log1.and.(obj.shape.eq.1)) then
neuf.p=neuf.p*pi/2*cos(neuf.r(1)/obj.size(1)*pi)
endif
neuf.p=neuf.p*
* (1.d0+flxa*(neuf.r(1)-flx0)+flxb*(neuf.r(1)-flx0)**2)*
* (1.d0+flya*(neuf.r(2)-fly0)+flyb*(neuf.r(2)-fly0)**2)
log1=(neuf.p.gt.0.d0)
if (neuf.p.le.0) then
if (log1) obj.count=obj.count-1
log1=.false.
endif
endif
if (dbgref) write(*,1) obj.name,obj.count,neuf.r,neuf.k,neuf.p
SOURCE_GO=log1
return
end
#---------------------------------------------------------
real*8 FUNCTION DFLUX(r,k)
# F0 is the integral neutron flux [1e14/s/cm^2]
# NEW!!! Returns dPhi/dK/dOmega in [1e14/s/cm^2/ster*Ang]
#---------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'source.inc'
real*8 r(3),k(3)
real*8 z,lam,vkt,k0
integer*4 iz
real*8 res,ph,pv,v(2),di,dj
real*8 LINTERP2D
1 format(a,6(2x,g10.4))
k0=sqrt(k(1)**2+k(2)**2+k(3)**2)
if (flxn.gt.0) goto 10 ! read lookup table
# Maxwell
vkt=3.370*sqrt(stemp/273.15)
DFLUX=sflux*k0**3*exp(-k0*k0/vkt/vkt)/2./pi/vkt**4
return
# Lookup table
#// FLXDIST = dPhi/dLambda in [1e12/s/cm^2/Ang]
10 lam=2*pi/k0
ph=1.d0
pv=1.d0
if (flxlog.gt.0) goto 20 ! logarithmic scale
# Linear scale
z=(lam-flxlam(1))/flxdlam
iz=int(z)+1
if(iz.lt.1.or.iz.ge.flxn) then
res=0.d0
else
res=(flxdist(iz)+(z-iz+1)*(flxdist(iz+1)-flxdist(iz)))
endif
goto 30
# Log scale
20 z=log(lam/flxlam(1))/flxdlam
iz=int(z)+1
if(iz.lt.1.or.iz.ge.flxn) then
res=0.d0
else
res=(flxdist(iz)+(z-iz+1)*(flxdist(iz+1)-flxdist(iz)))
endif
# search 2D-table
30 if (flxhnx.gt.0) then
v(1)=r(1)
v(2)=k(1)/k0
di=2.d0*flxhx/(flxhnx-1)
dj=2.d0*flxha/(flxhna-1)
ph=LINTERP2D(flxhp,flxhnx,flxhna,64,-flxhx,-flxha,di,dj,v)
endif
if (flxvnx.gt.0) then
v(1)=r(2)
v(2)=k(2)/k0
di=2.d0*flxvx/(flxvnx-1)
dj=2.d0*flxva/(flxvna-1)
pv=LINTERP2D(flxvp,flxvnx,flxvna,64,-flxvx,-flxva,di,dj,v)
endif
# write(*,1) 'DFLUX: ',R(1),K(1)/K0,R(2),K(2)/K0,LAM
# write(*,1) 'DFLUX: ',FLXHX,FLXHA,FLXVX,FLXVA
# write(*,1) 'DFLUX: ',RES,PH,PV
# pause
DFLUX=sflux/(2.d0*k0**2)*0.01*res*ph*pv
end