Source module last modified on Sun, 27 Mar 2005, 23:28;
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, 2004 ////
#//// ////
#//////////////////////////////////////////////////////////////////////
#////
#//// Subroutines describing objects - GUIDE or BENDER
#////
#////
#//////////////////////////////////////////////////////////////////////
#---------------------------------------------------------------------
SUBROUTINE GUIDE_INIT(obj)
#----------------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
real*8 zl
record /BENDER/ obj
integer*4 i
1 format(a,$)
# write(*,1) 'GUIDE_INIT '//OBJ.FRAME.NAME(1:10)
call SLIT_INIT(obj.frame)
# limit for number of slits = 127
if (obj.nlh.gt.127) obj.nlh=127
if (obj.nlv.gt.127) obj.nlv=127
# set A(I) = angles for lamellae
# set L(I) = positions of lamellae at the entry
if(obj.frame.size(3).gt.0) then
do i=0,obj.nlh
zl=i*1.d0/obj.nlh - 0.5d0
obj.ah(i)=zl*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
obj.lh(i)=zl*obj.frame.size(1)
enddo
do i=0,obj.nlv
zl=i*1.d0/obj.nlv - 0.5d0
obj.av(i)=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zl
obj.lv(i)=zl*obj.frame.size(2)
enddo
endif
# write(*,*) '... done. ',OBJ.FRAME.SIZE(3)
end
#---------------------------------------------------------------------
real*8 FUNCTION GUIDE_LAM(obj,id,il,z,ior)
# function describing lamella profile
# ID ... derivative
# IL ... lamella index
# Z ... distance from guide entry
# IOR ... horizontal (1) or vertical (2)
#----------------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
record /BENDER/ obj
real*8 a,f,x0
real*8 z
integer*4 id,il,ior
if (ior.eq.2) then ! vertical slit
f=obj.cv
a=obj.av(il)
x0=obj.lv(il)
else ! horizontal slit
f=obj.ch
a=obj.ah(il)
x0=obj.lh(il)
endif
# zero deriv.
if (id.le.0) then
GUIDE_LAM=x0+a*z+0.5*f*z**2
# 1st deriv.
else if (id.eq.1) then
GUIDE_LAM=a+f*z
# 2nd deriv.
else if (id.eq.2) then
GUIDE_LAM=f
else
GUIDE_LAM=0.d0
endif
end
#----------------------------------------------------------------------------
real*8 FUNCTION GUIDE_CROSS(kx,kz,x,z,alpha,ro)
# return path length along z-coordinate to a cross-point with parabolic surface
# if there are 2 solutions, take the minimum one which is > 0
# return 10^30 if there is no solution >0
# alpha .. tan(angle between lamella and guide axis)
# ro .. curvature
# x,z .. starting point (z // guide axis)
# kx,kz .. ray direction
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
implicit none
real*8 kx,kz,x,z,alpha,ro
real*8 lz,a,b,c
#10 FORMAT(a10,1x,6(1x,G11.4),4(1x,I4),2(1x,G10.4))
# write(*,10) 'cross',kx,kz,x,z,alpha,ro
a=0.5*ro*kz**2
b=alpha*kz-kx+ro*kz*z
c=alpha*z+0.5*ro*z**2-x
call QUADREQ(a,b,c,lz)
GUIDE_CROSS=lz*kz
end
#---------------------------------------------------------------------
SUBROUTINE GUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
# find next contact with a slit side
# moves to the next contact point, or to the exit
# turns K, i.e. returns new K=K+Q !
# *** INPUT:
# IH,IV ... slit indices
# R(3) ... neutron coordinate
# K(3) ... neutron k-vector
# *** RETURN:
# Q .. reflection vector (magnitude)
# DT .. time to reach the next contact point
# IC .. which wall, right(1), left(2), bottom (3) or top(4)
# IC=0 .. no contact, pass through
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
record /BENDER/ obj
real*8 r(3),k(3),q,dt
integer*4 ih,iv,ic
real*8 GUIDE_CROSS,GUIDE_LAM
real*8 kx,kz,x,z,a,f
real*8 lz(4),ang,t0,n(3)
integer*4 i
real*8 oscd,osca
common /oscbend/ oscd,osca
10 format(a10,1x,6(1x,g11.4),4(1x,i4),2(1x,g10.4))
z=r(3)
kz=k(3)
t0=obj.frame.size(3)-z
# HORIZONTAL RIGHT:
f=obj.ch
kx=k(1)
a=obj.ah(ih)-osca
x=r(1)-obj.dlh/2.d0-obj.lh(ih)-oscd-r(3)*osca
lz(2)=GUIDE_CROSS(kx,kz,x,z,a,f)
# HORIZONTAL LEFT:
a=obj.ah(ih+1)-osca
x=r(1)+obj.dlh/2.d0-obj.lh(ih+1)-oscd-r(3)*osca
lz(1)=GUIDE_CROSS(kx,kz,x,z,a,f)
# VERTICAL BOTTOM:
f=obj.cv
kx=k(2)
a=obj.av(iv)
x=r(2)-obj.dlv/2.d0-obj.lv(iv)
lz(4)=GUIDE_CROSS(kx,kz,x,z,a,f)
# VERTICAL TOP:
a=obj.av(iv+1)
x=r(2)+obj.dlv/2.d0-obj.lv(iv+1)
lz(3)=GUIDE_CROSS(kx,kz,x,z,a,f)
# write(*,10) 'times: ',LZ,T0
dt=min(lz(1),lz(2),lz(3),lz(4),t0)
ic=0
do i=1,4
if (dt.eq.lz(i)) ic=i
enddo
if (ic.eq.0) then ! no contact, passed through
dt=t0
q=0.d0
goto 50
endif
# get the surface normal vector
do i=1,3
n(i)=0.d0
enddo
if (ic.eq.2) then
ang=GUIDE_LAM(obj,1,ih,z+dt,1)
n(3)=-ang/sqrt((1.d0+ang**2))
n(1)=sqrt(1.d0-n(3)**2)
else if (ic.eq.1) then
ang=GUIDE_LAM(obj,1,ih+1,z+dt,1)
n(3)=ang/sqrt((1.d0+ang**2))
n(1)=-sqrt(1.d0-n(3)**2)
else if (ic.eq.4) then
ang=GUIDE_LAM(obj,1,iv,z+dt,2)
n(3)=-ang/sqrt((1.d0+ang**2))
n(2)=sqrt(1.d0-n(3)**2)
else if (ic.eq.3) then
ang=GUIDE_LAM(obj,1,iv+1,z+dt,2)
n(3)=ang/sqrt((1.d0+ang**2))
n(2)=-sqrt(1.d0-n(3)**2)
endif
# write(*,10) 'angles: ',ANG,N
# scattering vector:
q=0.d0
do i=1,3
q=q-k(i)*n(i)
enddo
# move to the point of reflection:
50 do i=1,3
r(i)=r(i)+k(i)/k(3)*dt
enddo
# turn K-vector:
do i=1,3
k(i)=k(i)+2.d0*q*n(i)
enddo
#
dt=dt/kz/hovm
end
#----------------------------------------------------
SUBROUTINE GUIDE_GO(obj,r,k,p,t,s)
# GO procedure for a guide with flat walls (TYP=1)
# INPUT: assume R,K at the entry in local coordinates !
# RETURN: R,K at the exit in local coordinates, P=P*transmission, T=T+passage time
#
implicit none
INCLUDE 'structures.inc'
record /BENDER/ obj
real*8 r(3),k(3),p,t,s
logical*4 BENDER_PASS
real*8 BENDER_REF
integer*4 ih,iv,i,ic
real*8 dum,kk,pp,tt,dt,q,co,si,beta,delta,r2(3),k2(3)
#10 FORMAT(a10,1x,6(1x,G11.4),4(1x,I4),2(1x,G10.4))
#11 FORMAT(a10,1x,8(1x,G11.4))
# check passage through the entry
if (.not.BENDER_PASS(obj,r,ih,iv)) goto 100
kk=sqrt(k(1)**2+k(2)**2+k(3)**2)
pp=1.d0
tt=0.d0
i=0
# write(*,10) 'start',R,K
# iterate through reflections
1 call GUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
# write(*,10) 'bounce',R,K,IH,IV,IC,I,DT,Q
tt=tt+dt
# debug: prevent infinite loops
i=i+1
if (i.gt.100000) then
write(*,*) obj.frame.name,obj.frame.count
write(*,*) 'too many iterations through bender, i=',i
stop
endif
if (ic.gt.0) then
pp=pp*BENDER_REF(ic-1,obj,q,s)
if (pp.lt.1.d-4) goto 100
goto 1
endif
# HORIZONTAL correction for beam deflection
beta=obj.ch*obj.frame.size(3)
if (beta.ne.0) then
delta=0.5*obj.ch*obj.frame.size(3)**2
si=beta/sqrt(1.d0+beta**2)
co=sqrt(1.d0-si**2)
r2(1)=(r(1)-delta)*co-(r(3)-obj.frame.size(3))*si
r2(2)=r(2)
r2(3)=(r(3)-obj.frame.size(3))*co+(r(1)-delta)*si
k2(1)=k(1)*co-k(3)*si
k2(2)=k(2)
k2(3)=k(3)*co+k(1)*si
do i=1,3
r(i)=r2(i)
k(i)=k2(i)
end do
r(3)=r(3)+obj.frame.size(3)
endif
# VERTICAL correction for beam deflection
beta=obj.cv*obj.frame.size(3)
if (beta.ne.0) then
delta=0.5*obj.cv*obj.frame.size(3)**2
si=beta/sqrt(1.d0+beta**2)
co=sqrt(1.d0-si**2)
r2(2)=(r(2)-delta)*co-(r(3)-obj.frame.size(3))*si
r2(1)=r(1)
r2(3)=(r(3)-obj.frame.size(3))*co+(r(2)-delta)*si
k2(2)=k(2)*co-k(3)*si
k2(1)=k(1)
k2(3)=k(3)*co+k(2)*si
do i=1,3
r(i)=r2(i)
k(i)=k2(i)
end do
r(3)=r(3)+obj.frame.size(3)
endif
# write(*,11) 'OK',R,K,PP,TT
# pause
# renormalize K due to numerical errors
dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
do i=1,3
k(i)=k(i)*kk/dum
enddo
p=p*pp
t=t+tt
return
100 continue
# write(*,11) 'failed',R,K,PP,TT
# pause
p=0.d0
end