Source module last modified on Tue, 29 Mar 2005, 23:55;
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 - PARABOLIC GUIDE
#////
#////
#//////////////////////////////////////////////////////////////////////
#---------------------------------------------------------------------
SUBROUTINE PGUIDE_INIT(obj)
#----------------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
real*4 PGUIDE_A
real*4 xx
real*8 f,zl,dif,a,h1,h2,v1,v2
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
# parabolic 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 parabola, flat walls
obj.ch=0.d0
else if (h2.gt.h1) then
dif=h2**2-h1**2
a=dif/4.d0/obj.frame.size(3)
obj.ch=a-h1**2*obj.frame.size(3)/dif
else if (h2.lt.h1) then
dif=h1**2-h2**2
a=dif/4.d0/obj.frame.size(3)
obj.ch=h2**2*obj.frame.size(3)/dif-a
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*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
obj.lh(i)=zl*obj.frame.size(1)
enddo
else ! parabolic lamellas, AH & LH are parameters & lengths, respectively
if (f.gt.0) f=f+obj.frame.size(3)
do i=0,obj.nlh
obj.ah(i)=PGUIDE_A(i,obj.nlh,obj.frame.size(1),f)
enddo
if (obj.typ.eq.3.and.obj.nlh.gt.1) then ! set optimum lengths of lamellae
do i=0,obj.nlh
xx=abs(i-0.5*obj.nlh)
if (xx.eq.0) then
obj.lh(i)=obj.frame.size(3)
else
obj.lh(i)=min(2.0*abs(obj.ch)/xx,obj.frame.size(3))
endif
# write(*,*) 'lam: ',I,' ',OBJ.LH(I),' ',
# & XX*OBJ.FRAME.SIZE(1)/OBJ.NLH
enddo
else
do i=0,obj.nlh
obj.lh(i)=obj.frame.size(3)
enddo
endif
endif
# VERTICAL
# parabolic 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=v2**2-v1**2
a=dif/4.d0/obj.frame.size(3)
obj.cv=a-v1**2*obj.frame.size(3)/dif
else if (v2.lt.v1) then
dif=v1**2-v2**2
a=dif/4.d0/obj.frame.size(3)
obj.cv=v2**2*obj.frame.size(3)/dif-a
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.d0/obj.nlv - 0.5d0
obj.av(i)=zl*(obj.h2-obj.frame.size(2))/obj.frame.size(3)
obj.lv(i)=zl*obj.frame.size(2)
enddo
else ! parabolic lamellas, AH & LH are parameters & lengths, respectively
if (f.gt.0) f=f+obj.frame.size(3)
do i=0,obj.nlv
obj.av(i)=PGUIDE_A(i,obj.nlv,obj.frame.size(2),f)
enddo
if (obj.typ.eq.3.and.obj.nlv.gt.1) then ! set optimum lengths of lamellae
do i=0,obj.nlv
xx=abs(i-0.5*obj.nlv)
if (xx.eq.0) then
obj.lv(i)=obj.frame.size(3)
else
obj.lv(i)=min(2.0*abs(obj.cv)/xx,obj.frame.size(3))
endif
enddo
else
do i=0,obj.nlv
obj.lv(i)=obj.frame.size(3)
enddo
endif
endif
end
#---------------------------------------------------------------------
real*8 FUNCTION PGUIDE_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,zz,aa,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
if (f.lt.0) then ! focal point before the guide
zz=z-f+abs(a)
else if (f.gt.0) then ! focal point behind the guide
zz=-z+f+obj.frame.size(3)+abs(a)
else
zz=0
endif
aa=sign(1.d0,a)*sqrt(abs(a))
if (zz.le.0.d0.and.f.ne.0) then
PGUIDE_LAM=0.d0
return
endif
# zero deriv.
if (id.le.0) then
if (f.eq.0) then
PGUIDE_LAM=x0+a*z
else
PGUIDE_LAM=2.d0*aa*sqrt(zz)
endif
# 1st deriv.
else if (id.eq.1) then
if (f.eq.0) then
PGUIDE_LAM=a
else
PGUIDE_LAM=-aa*sign(1.d0,f)/sqrt(zz)
endif
# 2nd deriv.
else if (id.eq.2) then
if (f.eq.0) then
PGUIDE_LAM=0.d0
else
PGUIDE_LAM=-aa/sqrt(zz)/zz/2.d0
endif
else
PGUIDE_LAM=0.d0
endif
end
#-------------------------------------------------------------------------------
real*4 FUNCTION PGUIDE_A(il,nl,w,f)
# parabola parameter for il-th lamella
# il ... lamella index, counted from right, right side il=0
# f ... focal distance
# w ... width of the entry
# 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 f,w,z
real*4 xx
integer*4 il,nl
xx=w*(il*1.e0/nl-0.5d0)
if (abs(xx).le.1.e-10) then
PGUIDE_A=0.d0
else
PGUIDE_A=sign(1.e0,xx)*(sqrt(f**2+xx**2)-abs(f))/2.e0
endif
z=sign(1.e0,xx)*(sqrt(f**2+xx**2)-abs(f))/2.e0
end
#----------------------------------------------------------------------------
real*8 FUNCTION PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
# 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 < result < lmax
# a .. parabola parameter
# f .. focal distance from guide entry (origin of z coordinate)
# lmax .. limit distance (lamella length)
# x,z .. starting point (z // guide axis)
# kx,kz .. ray direction
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
implicit none
real*8 eps
parameter (eps=1.d-7)
real*8 kx,kz,x,z,a,f,lmax
real*8 lz,y1,y2,tang,s,aa,dtm
#10 FORMAT(a10,1x,8(1x,G13.7))
# write(*,10) 'cross',kx,kz,x,z,a,f,lmax
if (abs(kx).lt.1.d-6*kz) then ! beam along z
if (a.gt.eps) then
lz=f+sign(1.d0,f)*(a-x**2/a/4.d0)-z
else
lz=1.d30
endif
else
tang=kz/kx
dtm=a*(1+tang**2) + sign(1.d0,f)*(x*tang+f-z)
if (dtm.lt.0.d0) then
lz=1.d30
else
s=2*sign(1.d0,f)*sign(1.d0,kx)
aa=sqrt(a)
y1=(s*aa*(-aa*abs(tang)+sqrt(dtm))-x)*tang
y2=(s*aa*(-aa*abs(tang)-sqrt(dtm))-x)*tang
# write(*,10) 'cross',Y1,Y2,dtm
if(y1.le.eps.and.y2.le.eps) then
lz=1.d30
else
if (y1.gt.eps.and.y2.gt.eps) then
lz=min(y1,y2)
else
lz=max(y1,y2)
endif
endif
endif
endif
# write(*,10) 'cross',Y1,Y2,LZ,lmax
# pause
if (lz.gt.lmax) lz=1.d30
PGUIDE_CROSS=lz
end
#---------------------------------------------------------------------
SUBROUTINE PGUIDE_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 PGUIDE_CROSS,GUIDE_CROSS,PGUIDE_LAM
real*8 kx,kz,x,z,a,f,lmax
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
# 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=abs(obj.ah(ih))
x=r(1)-obj.dlh/2.d0
if (f.gt.0) f=f+obj.frame.size(3)
if (f.lt.0) lmax=obj.lh(ih)-z
lz(2)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
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=abs(obj.ah(ih+1))
x=r(1)+obj.dlh/2.d0
if (f.lt.0) lmax=obj.lh(ih+1)-z
lz(1)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
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=abs(obj.av(iv))
x=r(2)-obj.dlv/2.d0
if (f.gt.0) f=f+obj.frame.size(3)
if (f.lt.0) lmax=obj.lv(iv)-z
lz(4)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
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=abs(obj.av(iv+1))
x=r(2)+obj.dlv/2.d0
if (f.lt.0) lmax=obj.lv(iv+1)-z
lz(3)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
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=PGUIDE_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=PGUIDE_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=PGUIDE_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=PGUIDE_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: ',
# & PGUIDE_LAM(OBJ,0,IH,R(3),1)+OBJ.DLH/2.D0,
# & PGUIDE_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 PGUIDE_GO(obj,r,k,p,t,s)
# GO procedure for parabolic guide (TYP=2)
# 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
real*8 lx,xx,fx,sx,sk,ld,z,detm,dth,dtv
# LOGICAL*4 rep
# rep=(OBJ.FRAME.NAME(1:5).EQ.'guide'.AND.OBJ.FRAME.count.GT.10000)
# rep=(rep.AND..NOT.OBJ.FRAME.NAME(1:6).EQ.'guide_')
#10 FORMAT(a10,1x,6(1x,G13.7),3(1x,I4),2(1x,G10.4))
#11 FORMAT(a10,1x,8(1x,G13.7))
# if (rep) write(*,10) 'guide entry ',OBJ.CH,R
if (obj.typ.eq.3.and.(obj.ch.gt.0.or.obj.cv.gt.0)) then
ld=obj.frame.size(3)-r(3) ! distance to the guide exit
# try horizontal
if (obj.ch.gt.0.and.obj.nlh.gt.2) then ! focus is behind exit
xx=r(1)
sx=sign(1.d0,xx)
sk=sign(1.d0,k(1))
fx=2.d0*obj.ch*obj.frame.size(1)/obj.nlh
lx=obj.frame.size(3)
if(abs(xx).gt.eps) lx=min(fx/abs(xx),lx) ! "optimum" lamella length
# if (rep) write(*,10) 'lam1 ',xx,fx,lx
if (lx.lt.ld) then
z=ld/k(3)-xx/k(1)
detm=z**2+4.d0*(ld*xx-fx*sx)/k(1)/k(3)
dth=(z+sx*sk*sqrt(detm))/2.d0 ! positive solution of quadratic equation
else
dth=0.d0
endif
else
dth=0.d0
endif
# try vertical
if (obj.cv.gt.0.and.obj.nlv.gt.2) then ! focus is behind exit
xx=r(2)
sx=sign(1.d0,xx)
sk=sign(1.d0,k(2))
fx=2.d0*obj.cv*obj.frame.size(2)/obj.nlv
lx=obj.frame.size(3)
if(abs(xx).gt.eps) lx=min(fx/abs(xx),lx) ! "optimum" lamella length
if (lx.lt.ld) then
z=ld/k(3)-xx/k(2)
detm=z**2 + 4.d0*(ld*xx-fx*sx)/k(2)/k(3)
dtv=(z+sx*sk*sqrt(detm))/2.d0 ! positive solution of quadratic equation
else
dtv=0.d0
endif
else
dtv=0.d0
endif
dt=min(dth,dtv)
#
if (dt.gt.0) then
do i=1,3
r(i)=r(i)+k(i)*dt
enddo
t=t+dt
endif
endif
# if (rep) write(*,10) 'lam2 ',DTH,DTV,DT
# if (rep) write(*,10) 'start',R,K
# 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
# if (rep) write(*,10) 'start',R,K
# iterate through reflections
1 call PGUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
# if (rep) write(*,10) 'bounce',R,K,IH,IV,IC,DT,Q
tt=tt+dt
# debug: prevent infinite loops
# I=I+1
# IF (I.GT.100000) THEN
#
# 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
# if (rep) write(*,11) 'OK',R,K,PP,TT
# if (rep) 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
# if (rep) write(*,10) 'failed',R,K,IH,IV
# if (rep) pause
p=0.d0
end