Source module last modified on Wed, 30 Mar 2005, 10:16;
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 - ALL COLLIMATOR TYPES
#//// Envelope for collimator segments of any kind:
#//// TUBE, SOLLER , GUIDE/BENDER, PARABOLIC GUIDE
#////
#//////////////////////////////////////////////////////////////////////
#------------------------------------
SUBROUTINE BENDER_INIT(obj)
#
implicit none
INCLUDE 'structures.inc'
record /BENDER/ obj
if (obj.typ.eq.2.or.obj.typ.eq.3) then
call PGUIDE_INIT(obj)
else if (obj.typ.eq.4) then
call EGUIDE_INIT(obj)
else
call GUIDE_INIT(obj)
endif
end
#---------------------------------------------------------------------
real*8 FUNCTION BENDER_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
integer*4 id,il,ior
real*8 PGUIDE_LAM,EGUIDE_LAM,GUIDE_LAM,z
if (obj.typ.eq.2.or.obj.typ.eq.3) then
BENDER_LAM=PGUIDE_LAM(obj,id,il,z,ior)
else if (obj.typ.eq.4) then
BENDER_LAM=EGUIDE_LAM(obj,id,il,z,ior)
else
BENDER_LAM=GUIDE_LAM(obj,id,il,z,ior)
endif
end
#-------------------------------------------------------------------
SUBROUTINE QUADREQ(a,b,c,x)
# Solve quadratic equation A*X^2 + B*X + C = 0
# Try to find a solution > EPS=1E-10
# 1) no solution .. return 10^30
# 2) 1 solution .. return this
# 3) 2 solutions .. return the smaller one
#-------------------------------------------------------------------
implicit none
real*8 eps
parameter (eps=1.d-8)
real*8 a,b,c,x,x1,x2,det
if (a.eq.0) then
if (abs(b).lt.eps) then
goto 20
else
x=-c/b
goto 30
endif
else
det=b**2-4*a*c
if (det.eq.0.) then
x=-b/2./a
goto 30
else if (det.lt.0.) then
goto 20
else
det=sqrt(det)
x1=(-b+det)/2./a
x2=(-b-det)/2./a
if (x1.gt.eps.and.x2.gt.eps) then
x=min(x1,x2)
else if (x1.gt.eps) then
x=x1
else if (x2.gt.eps) then
x=x2
else
goto 20
endif
endif
endif
30 if (x.lt.eps) goto 20
return
20 x=1.d30
end
#--------------------------------------------------------
logical*4 FUNCTION BENDER_PASS(obj,r,ih,iv)
# Checks, whether neutron fits inside any slit and
# returns slit indices
#
implicit none
INCLUDE 'structures.inc'
integer*4 ih,iv
logical*4 log1
real*8 BENDER_LAM
real*8 r(3),jh,jv,w,h
record /BENDER/ obj
real*8 oscd,osca
common /oscbend/ oscd,osca
1 format(a10,1x,i4,1x,i4,1x,6(g11.4))
w=2.d0*abs(BENDER_LAM(obj,0,0,r(3),1))
h=2.d0*abs(BENDER_LAM(obj,0,0,r(3),2))
jh=((r(1)-oscd-r(3)*osca)/w+0.5)*obj.nlh
jv=(r(2)/h+0.5)*obj.nlv
ih=nint(jh-0.5)
iv=nint(jv-0.5)
# write(*,1) 'pass',IH,IV,R,jh,jv,-OSCD-R(3)*OSCA
log1=((abs(jh-nint(jh))*w/obj.nlh.ge.obj.dlh/2.).and.
1 (abs(jv-nint(jv))*h/obj.nlv.ge.obj.dlv/2.).and.
1 (jh.gt.0.).and.
1 (jv.gt.0.).and.
1 (jh.lt.obj.nlh).and.
1 (jv.lt.obj.nlv))
BENDER_PASS=log1
end
#---------------------------------------------------
real*8 FUNCTION BENDER_REF(id,obj,q,s)
# returns reflectivity for given momentum transfer Q
# ID identifies which surface is touched
# ID=0 left
# ID=1 right
# ID=2 top
# ID=3 bottom
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
integer*4 id
record /BENDER/ obj
real*8 q,s
integer*4 iz,nr
real*8 z,dq,q1,gamma,r
integer*4 m_n(5)
character*3 m_name(5)
real*8 m_alpha(128,5), m_ref1(128,5),m_ref2(128,5)
common /mirror/ m_alpha,m_ref1,m_ref2,m_n,m_name
# get critical angle, reflectivity and index to lookup table
if (id.eq.0) then
if (s.ge.0) then
gamma=obj.ghlu
r=obj.rhlu
nr=obj.nhlu
else
gamma=obj.ghld
r=obj.rhld
nr=obj.nhld
endif
else if (id.eq.1) then
if (s.ge.0) then
gamma=obj.ghru
r=obj.rhru
nr=obj.nhru
else
gamma=obj.ghrd
r=obj.rhrd
nr=obj.nhrd
endif
else if (id.eq.2) then
gamma=obj.gvt
r=obj.rvt
nr=obj.nvt
else if (id.eq.3) then
gamma=obj.gvb
r=obj.rvb
nr=obj.nvb
else
gamma=0.
r=0.
endif
# no reflection for Q<0 or gamma=0
if (gamma.le.0.or.q.lt.0) then
BENDER_REF=0
return
endif
# no lookup table, just step function for 0 < Q < 2*pi*gamma
if (nr.le.0.or.nr.gt.5) then
if (q.ge.0.and.q.lt.2*pi*gamma) then
BENDER_REF=r
else
BENDER_REF=0
endif
else
q1=q/2/pi/gammani
dq=(m_alpha(m_n(nr),nr)-m_alpha(1,nr))/(m_n(nr)-1)
z=(q1-m_alpha(1,nr))/dq
iz=int(z)+1
if (z.lt.0.or.z.ge.m_n(nr).or.iz.ge.m_n(nr)) then
BENDER_REF=0
else if (s.ge.0) then
BENDER_REF=m_ref1(iz,nr)+(z-iz+1)*
& (m_ref1(iz+1,nr)-m_ref1(iz,nr))
else if (s.lt.0) then
BENDER_REF=m_ref2(iz,nr)+(z-iz+1)*
& (m_ref2(iz+1,nr)-m_ref2(iz,nr))
else
BENDER_REF=0
endif
endif
end
#----------------------------------------------------
logical*4 FUNCTION BENDER_GO(obj,neui,neuf)
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
record /BENDER/ obj
record /NEUTRON/ neui,neuf
integer*4 i
real*8 v(3),k(3),r(3),p,t
real*4 RAN1
real*8 dj,oscd,osca
common /oscbend/ oscd,osca
1 format(a10,2x,i8,2x,10(1x,g12.6))
# dbgref=(OBJ.FRAME.NAME(1:5).EQ.'col2 ')
# Convert to local coordinate system and move to the entry
call SLIT_PRE(obj.frame,neui.r,neui.k,v,k)
# if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,V,K
do i=1,2
r(i)=v(i)-v(3)/k(3)*k(i)
enddo
r(3)=0.
p=1.d0
t=-v(3)/hovm/k(3)
if (obj.typ.lt.0.or.obj.frame.size(3).le.0) goto 700 ! collimator ignored
# Make a random shift to simulate oscillating collimator
oscd=0
osca=0
if (obj.oscilate.gt.0) then
dj=(RAN1()-0.5)/obj.nlh
osca=dj*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
oscd=dj*obj.frame.size(1)
endif
if (obj.typ.eq.0) then
call SOLLER_GO(obj,r,k,p,t,neui.s)
else if (obj.typ.eq.1) then
call GUIDE_GO(obj,r,k,p,t,neui.s)
else if (obj.typ.eq.2.or.obj.typ.eq.3) then
call PGUIDE_GO(obj,r,k,p,t,neui.s)
else if (obj.typ.eq.4) then
call EGUIDE_GO(obj,r,k,p,t,neui.s)
else
goto 300
endif
if (p.le.0.d0) goto 300
700 do i=1,3
neuf.r(i)=r(i)
neuf.k(i)=k(i)
end do
neuf.p=neui.p*p
neuf.t=neui.t+t
neuf.s=neui.s
obj.frame.count=obj.frame.count+1
BENDER_GO=.true.
# if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,
# & NEUF.R,NEUF.K,NEUF.P
# if (dbgref) pause
return
300 neuf.p=0
# if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,NEUF.P
# if (dbgref) pause
BENDER_GO=.false.
end
#--------------------------------------------------------------
SUBROUTINE SOLLER_GO(obj,r,k,p,t)
# GO procedure for a simple collimator (non reflecting, TYP=0)
# 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 'const.inc'
INCLUDE 'structures.inc'
record /BENDER/ obj
real*8 r(3),k(3),p,t
logical*4 log1, BENDER_PASS
integer*4 ih,iv,ih1,iv1,i
#1 FORMAT(a10,1x,I4,1x,I4,1x,6(G11.4))
# check passage through the entry
log1=BENDER_PASS(obj,r,ih,iv)
# write(*,1) OBJ.FRAME.NAME,IH,IV,R,K
if (.not.log1) goto 100
# move to the exit
do i=1,2
r(i)=r(i)+obj.frame.size(3)/k(3)*k(i)
enddo
r(3)=obj.frame.size(3)
t=t+r(3)/hovm/k(3)
# check passage through the same slit at the exit
log1=(log1.and.BENDER_PASS(obj,r,ih1,iv1))
# write(*,1) OBJ.FRAME.NAME,IH1,IV1,R,K
if ((.not.log1).or.(ih1.ne.ih).or.(iv1.ne.iv)) goto 100
return
# no passage
100 p=0.d0
# pause
end