Source module last modified on Tue, 29 Mar 2005, 23:56;
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, 2005 ////
#//// ////
#//////////////////////////////////////////////////////////////////////
#////
#//// Subroutines describing objects - ELLIPTIC GUIDE
#////
#////
#//////////////////////////////////////////////////////////////////////
#---------------------------------------------------------------------
SUBROUTINE EGUIDE_INIT(obj)
#----------------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
real*4 EGUIDE_A
real*8 f,zl,dif,h1,h2,v1,v2,w
record /BENDER/ obj
integer*4 i
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
# HORIZONTAL
# elliptic profile is determined by the dimensions
h1=obj.frame.size(1)
h2=obj.w2
if (h2.eq.h1.or.obj.ch.eq.0) then ! no ellipsa, flat walls
obj.ch=0.d0
else if (h2.gt.h1) then
dif=sqrt(h2**2-h1**2)
obj.ch=-obj.frame.size(3)*h2/dif
else
dif=sqrt(h1**2-h2**2)
obj.ch=obj.frame.size(3)*h1/dif
endif
f=obj.ch
if (f.eq.0) then ! flat lamellas, AH & LH are angles & positions, respectively
do i=0,obj.nlh
zl=i*1.d0/obj.nlh - 0.5d0
obj.ah(i)=zl*(h2-h1)/obj.frame.size(3)
obj.lh(i)=zl*h1
enddo
else ! elliptic lamellas, AH & LH are parameters & lengths, respectively
w=max(h1,h2)
do i=0,obj.nlh
obj.ah(i)=EGUIDE_A(i,obj.nlh,w)
obj.lh(i)=obj.frame.size(3)
enddo
endif
# VERTICAL
# elliptic profile is determined by the dimensions
v1=obj.frame.size(2)
v2=obj.h2
if (v2.eq.v1.or.obj.cv.eq.0) then ! no parabola, flat walls
obj.cv=0.d0
else if (v2.gt.v1) then
dif=sqrt(v2**2-v1**2)
obj.cv=-obj.frame.size(3)*v2/dif
else
dif=sqrt(v1**2-v2**2)
obj.cv=obj.frame.size(3)*v1/dif
endif
f=obj.cv
if (f.eq.0) then ! flat lamellas, AH & LH are angles & positions, respectively
do i=0,obj.nlv
zl=i*1.e0/obj.nlv - 0.5d0
obj.av(i)=zl*(v2-v1)/obj.frame.size(3)
obj.lv(i)=zl*v1
enddo
else ! elliptic lamellas, AH & LH are parameters & lengths, respectively
w=max(v1,v2)
do i=0,obj.nlv
obj.av(i)=EGUIDE_A(i,obj.nlv,w)
obj.lv(i)=obj.frame.size(3)
enddo
endif
end
#---------------------------------------------------------------------
real*8 FUNCTION EGUIDE_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,b,zz,aa,x0
real*8 z
integer*4 id,il,ior
#// a is the ellipse main axis // z (or slope for a planar lamellla)
#// b is the ellipse smaller axis
if (ior.eq.2) then ! vertical slit
a=obj.cv
b=obj.av(il)
x0=obj.lv(il)
else ! horizontal slit
a=obj.ch
b=obj.ah(il)
x0=obj.lh(il)
endif
if (a.lt.0) then ! focal point before the guide entry
zz=z-obj.frame.size(3)
else ! focal point behind the guide
zz=z
endif
aa=a**2-zz**2
if(a.ne.0) then
if(aa.le.0) then
EGUIDE_LAM=0.d0
return
else
aa=sqrt(aa)
endif
endif
# zero deriv.
if (id.le.0) then
if (a.eq.0) then
EGUIDE_LAM=x0+b*z
else
EGUIDE_LAM=b/abs(a)*aa
endif
# 1st deriv.
else if (id.eq.1) then
if (a.eq.0) then
EGUIDE_LAM=b
else
EGUIDE_LAM=-b/abs(a)/aa*zz
endif
# 2nd deriv.
else if (id.eq.2) then
if (a.eq.0) then
EGUIDE_LAM=0.d0
else
EGUIDE_LAM=-b*abs(a)/aa/aa**2
endif
else
EGUIDE_LAM=0.d0
endif
end
#-------------------------------------------------------------------------------
real*4 FUNCTION EGUIDE_A(il,nl,w)
# ellipsa parameter for il-th lamella = smaller axis
# il ... lamella index, counted from right, right side il=0
# w ... small axis of the outer profile
# nl ... number of slits (number of lamellae + 1)
# sign(A) determines which side from the guide center: right/bottom(<0) or left/top(>0)
#--------------------------------------------------------------------------------
implicit none
real*8 w
integer*4 il,nl
EGUIDE_A=w*(il*1.e0/nl-0.5e0)
end
#----------------------------------------------------------------------------
real*8 FUNCTION EGUIDE_CROSS(kx,kz,x,z,b,a,lmax,glen)
# return path length along z-coordinate to a cross-point with elliptic surface
# if there are 2 solutions, take the minimum one which is > 0
# return 10^30 if there is no solution 0 < result < lmax
# b .. smaller ellipsa axis
# a .. main ellipsa axis
# lmax .. limit distance (lamella length)
# x,z .. starting point (z // guide axis)
# kx,kz .. ray direction
# glen .. guide length
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
implicit none
real*8 eps
parameter (eps=1.d-7)
real*8 kx,kz,x,z,b,a,lmax,zz,glen
real*8 lz,y1,y2,dtm,dnom,t0
if (a.lt.0) then ! focal point before the guide entry
zz=z-glen
else ! focal point behind the guide
zz=z
endif
dnom=(kx*a)**2 + (kz*b)**2
dtm=(a*b)**2*(dnom-(kx*zz-kz*x)**2)
t0=x*kx*a**2 + zz*kz*b**2
if (dtm.lt.0.d0) then ! no solution
lz=1.d30
else
y1=(-t0+sqrt(dtm))/dnom
y2=(-t0-sqrt(dtm))/dnom
if(y1.le.eps.and.y2.le.eps) then ! no positive solution
lz=1.d30
else
if (y1.gt.eps.and.y2.gt.eps) then ! both positive, take the smaller one
lz=min(y1,y2)
else ! take the positive one
lz=max(y1,y2)
endif
endif
endif
if (lz.gt.lmax) lz=1.d30 ! no reflection behind the guide
EGUIDE_CROSS=lz*kz
end
#---------------------------------------------------------------------
SUBROUTINE EGUIDE_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, left(1), right(2), top(3), bottom (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 EGUIDE_CROSS,GUIDE_CROSS,EGUIDE_LAM
real*8 kx,kz,x,z,a,f,lmax,glen
real*8 lz(4),ang,t0,n(3)
integer*4 i
real*8 oscd,osca
common /oscbend/ oscd,osca
#10 FORMAT(a11,1x,6(1x,G11.5),2(1x,I4),2(1x,G10.4))
# write(*,10) 'CON START: ',R,K,IH,IV,OBJ.CH
z=r(3)
kz=k(3)
t0=obj.frame.size(3)-z ! time to the guide end
glen=obj.frame.size(3)
# HORIZONTAL RIGHT:
f=obj.ch
kx=k(1)
lmax=t0
if (f.eq.0) then
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)
else
a=obj.ah(ih)
x=r(1)-obj.dlh/2.d0
lz(2)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
endif
# HORIZONTAL LEFT:
if (f.eq.0) then
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)
else
a=obj.ah(ih+1)
x=r(1)+obj.dlh/2.d0
lz(1)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
endif
# VERTICAL BOTTOM:
f=obj.cv
kx=k(2)
lmax=t0
if (f.eq.0) then
a=obj.av(iv)
x=r(2)-obj.dlv/2.d0-obj.lv(iv)
lz(4)=GUIDE_CROSS(kx,kz,x,z,a,f)
else
a=obj.av(iv)
x=r(2)-obj.dlv/2.d0
lz(4)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
endif
# VERTICAL TOP:
if (f.eq.0) then
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)
else
a=obj.av(iv+1)
x=r(2)+obj.dlv/2.d0
lz(3)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
endif
# write(*,10) 'kz*times: ',LZ(1),LZ(2)
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=EGUIDE_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=EGUIDE_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=EGUIDE_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=EGUIDE_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
# write(*,10) 'lamellae: ',
# & EGUIDE_LAM(OBJ,0,IH,R(3),1)+OBJ.DLH/2.D0,
# & EGUIDE_LAM(OBJ,0,IH+1,R(3),1)-OBJ.DLH/2.D0
# write(*,10) ' CON HIT: ',R,K,IC,OBJ.FRAME.COUNT,DT,Q
# pause
end
#----------------------------------------------------
SUBROUTINE EGUIDE_GO(obj,r,k,p,t,s)
# GO procedure for elliptic guide (TYP=4)
# INPUT: assume R,K at the entry in local coordinates, i.e. R(3)=0 !
# RETURN: R,K at the exit in local coordinates, P=P*transmission, T=T+passage time
#
implicit none
INCLUDE 'structures.inc'
real*8 eps
parameter (eps=1.d-7)
record /BENDER/ obj
real*8 r(3),k(3),p,t,s
logical*4 BENDER_PASS
real*8 BENDER_REF
integer*4 ih,iv,ic,i
real*8 dum,kk,pp,tt,dt,q
10 format(a11,1x,6(1x,g11.5),2(1x,i4),2(1x,g10.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
# iterate through reflections
1 call EGUIDE_CON(obj,r,k,ih,iv,ic,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
# 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
# write(*,10) 'EXIT: ',R,K,I,OBJ.FRAME.COUNT,TT
return
100 continue
p=0.d0
# write(*,10) 'STOP: '
end