Source module last modified on Wed, 13 Jul 2005, 16:20;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#//////////////////////////////////////////////////////////////////////
#//// ////
#//// NEutron Scattering Simulation - v.2.0, (c) J.Saroun, 1999 ////
#//// ////
#//////////////////////////////////////////////////////////////////////
#////
#//// Subroutines describing objects - BENDER
#////
#//// * LOGICAL*4 FUNCTION BENDER_PASS(OBJ,R,IH,IV,exit)
#//// * LOGICAL*4 FUNCTION CONTACT(X0,Z0,alpha,RO,kx,kz,T)
#//// * REAL*8 FUNCTION BENDER_REF(ID,OBJ,Q,S)
#//// * SUBROUTINE BENDER_INIT(OBJ)
#//// * LOGICAL*4 FUNCTION BENDER_GO(OBJ,NEUI,NEUF)
#////
#//////////////////////////////////////////////////////////////////////
#
logical*4 FUNCTION BENDER_PASS(obj,r,ih,iv,exit)
#
# returns slit coordinates
#
implicit none
INCLUDE 'nesobj_bender.inc'
integer*4 ih,iv,exit
logical*4 log1
real*8 r(3),jh,jv,w,h
record /BENDER/ obj
if (exit.eq.1) then
w=obj.w2
h=obj.h2
else
w=obj.frame.size(1)
h=obj.frame.size(2)
endif
jh=(r(1)/w+0.5)*obj.nlh
jv=(r(2)/h+0.5)*obj.nlv
ih=nint(jh-0.5)
iv=nint(jv-0.5)
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
#
# write(*,*) 'PASS : ',JH,IH,OBJ.FRAME.COUNT
#
#
#
# endif
end
#
logical*4 FUNCTION CONTACT(x0,z0,alpha,ro,kx,kz,t)
#
# to reach it
# X0,Z0 ... initial coordinates of the neutron with respect
# to the lamella front end
# alpha ... lamella inclination angle (without curvature)
# R0 ... lamella curvature
# kx,kz ... transversal and longitudinal components of neutron
# k vector
#
implicit none
logical*4 log1, QUADREQ
real*8 x0,z0,alpha,ro,kx,kz,t,a,b,c
a=0.5*ro*kz**2
b=alpha*kz-kx+ro*kz*z0
c=alpha*z0+0.5*ro*z0**2-x0
log1=QUADREQ(a,b,c,t)
CONTACT=log1
end
#
real*8 FUNCTION BENDER_REF(id,obj,q,s)
#
# ID identifies which surface is touched
# ID=0 left
# ID=1 right
# ID=2 top
# ID=3 bottom
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'nesobj_bender.inc'
integer*4 iz,id,nr
real*8 q,s,z,dq,q1,gamma,r
record /BENDER/ obj
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
if (gamma.le.0.or.q.le.0) then
BENDER_REF=0
return
endif
if(nr.le.0.or.nr.gt.5) then
if (q.lt.2*pi*gamma) then
BENDER_REF=r
else
BENDER_REF=0
endif
else
q1=q/2/pi/gammani
dq=m_alpha(2,nr)-m_alpha(1,nr)
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)*
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)*
1 (m_ref2(iz+1,nr)-m_ref2(iz,nr))
else
BENDER_REF=0
endif
endif
end
# -------------------------------
SUBROUTINE BENDER_INIT(obj)
#
implicit none
INCLUDE 'nesobj_bender.inc'
record /BENDER/ obj
call SLIT_INIT(obj.frame)
obj.typ=0
if (obj.curv.ne.0) then
obj.typ=obj.typ+1
endif
if (obj.ghlu.ne.0.or.
* obj.ghld.ne.0.or.
* obj.ghru.ne.0.or.
* obj.ghrd.ne.0.or.
* obj.gvt.ne.0.or.
* obj.gvb.ne.0) then
obj.typ=obj.typ+2
endif
end
#xxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCx
#
logical*4 FUNCTION BENDER_GO(obj,neui,neuf)
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'nesobj_bender.inc'
record /BENDER/ obj
record /NEUTRON/ neui,neuf
logical*4 log1, BENDER_PASS,CONTACT
real*8 BENDER_REF
integer*4 ih,iv,ih1,iv1,i
real*8 v(3),k(3),r(3),r2(3)
real*8 al,ar,at,ab,tl,tr,tt,tb,zl,zr,zt,zb,xl,xr,xt,xb
real*8 kk,dum,beta0,delta0,p,pp,dt,t,q,tini,dphi
# LOGICAL*4 FLAG
# CHARACTER*14 dname
# CHARACTER*1 CH
# 100 format('tra',I3,a4,'.dat')
101 format(1x,7(g10.3,2x),a1)
# 102 format(1x,5(E10.3,2x),2x,a10)
# 103 format(1x,3(E10.3,2x),2x,I4,2x,a10)
neuf=neui
call SLIT_PRE(obj.frame,neui.r,neui.k,v,k)
neuf.t=neui.t-v(3)/hovm/k(3)
tini=neuf.t ! initial time
pp=1.
beta0=0.
log1=.true.
do 10 i=1,2
10 r(i)=v(i)-v(3)/k(3)*k(i)
r(3)=0.
if (obj.frame.size(3).le.0) goto 210 ! collimator ignored
#/// check the pass through the entry
# FLAG=(OBJ.FRAME.NAME(1:4).EQ.'col4'.AND.
# * OBJ.FRAME.COUNT.GT.1000.AND.OBJ.FRAME.COUNT.LT.1011)
# FLAG=.FALSE.
# IF(FLAG) then
# write(*,101) (NEUI.R(i),i=1,3),(NEUI.K(i),i=1,3)
# write(*,101) (V(i),i=1,3),(K(i),i=1,3),NEUI.P
# write(*,101) (R(i),i=1,3)
# write(*,*) BENDER_PASS(OBJ,R,IH,IV,0), IH,IV
# ENDIF
if (.not.BENDER_PASS(obj,r,ih,iv,0)) goto 300
beta0=obj.curv*obj.frame.size(3)
# CH='I'
# write(*,103) (R(I),I=1,3),OBJ.FRAME.COUNT,
# 1 OBJ.FRAME.NAME
# write(dname,100) OBJ.FRAME.COUNT,OBJ.FRAME.NAME
# if (dname(4:4).eq.' ') dname(4:4)='0'
# if (dname(5:5).eq.' ') dname(5:5)='0'
#
# write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH
# **** normal collimator ****
if (obj.typ.eq.0) then
dt=obj.frame.size(3)/k(3) ! time of flight
do i=1,2
r2(i)=r(i)+dt*k(i)
enddo
r2(3)=obj.frame.size(3)
log1=(log1.and.BENDER_PASS(obj,r2,ih1,iv1,1))
# IF(FLAG) THEN
# write(*,101) (R2(i),i=1,3),(K(i),i=1,3),NEUI.P
# IF (LOG1) write(*,*) BENDER_PASS(OBJ,R,IH,IV,0), IH,IV
# CALL GETSTATE
# pause
# ENDIF
if (log1.and.(ih1.eq.ih).and.(iv1.eq.iv)) then
#
# write(15,101) (R2(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH
# write(*,*) dname
# pause
do i=1,3
r(i)=r2(i) ! move to colimator exit
enddo
neuf.t=neuf.t+dt/hovm
goto 210 ! free passage
else
# CLOSE(15)
goto 300 ! no passage
endif
endif
# **** neutron guide ****
kk=sqrt(k(1)**2+k(2)**2+k(3)**2)
# left
zl=(ih+1)*1./obj.nlh-0.5
xl=zl*obj.frame.size(1)-0.5*obj.dlh
al=(obj.w2-obj.frame.size(1))/obj.frame.size(3)*zl
# right
zr=ih*1./obj.nlh-0.5
xr=zr*obj.frame.size(1)+0.5*obj.dlh
ar=(obj.w2-obj.frame.size(1))/obj.frame.size(3)*zr
# top
zt=(iv+1)/obj.nlv-0.5
xt=zt*obj.frame.size(2)-0.5*obj.dlv
at=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zt
# bottom
zb=iv*1./obj.nlv-0.5
xb=zb*obj.frame.size(2)+0.5*obj.dlv
ab=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zb
#***** beginning of the guide tracing cycle
50 continue
if (CONTACT(r(1)-xl,r(3),al,obj.curv,k(1),k(3),t)) then
tl=t
else
tl=1.d35
endif
if (CONTACT(r(1)-xr,r(3),ar,obj.curv,k(1),k(3),t)) then
tr=t
else
tr=1.d35
endif
if (CONTACT(r(2)-xt,r(3),at,0.d0,k(2),k(3),t)) then
tt=t
else
tt=1.d35
endif
if (CONTACT(r(2)-xb,r(3),ab,0.d0,k(2),k(3),t)) then
tb=t
else
tb=1.d35
endif
dt=min(tl,tr,tt,tb)
if(dt.eq.1.d35) then
dt=0.
endif
# go to a point of reflection
do i=1,3
r2(i)=r(i) ! remember old position !
enddo
do i=1,3
r(i)=r(i)+k(i)*dt ! go to the contact point
enddo
if (r(3).gt.obj.frame.size(3)) then ! bender exit
dt=(obj.frame.size(3)-r2(3))/k(3)
do i=1,3
r(i)=r2(i)+dt*k(i)
enddo
neuf.t=neuf.t+dt/hovm
#
# write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH
goto 199
endif
neuf.t=neuf.t+dt/hovm
# CH='X'
if (dt.eq.tl) then
q=k(1)-(al+r(3)*obj.curv)*kk
p=BENDER_REF(0,obj,q,neui.s)
if (p.gt.0) k(1)=k(1)-2*q
#
else if (dt.eq.tr) then
q=-k(1)+(ar+r(3)*obj.curv)*kk
p=BENDER_REF(1,obj,q,neui.s)
if (p.gt.0) k(1)=k(1)+2*q
#
else if (dt.eq.tt) then
q=k(2)-at*kk
p=BENDER_REF(2,obj,q,neui.s)
if (p.gt.0) k(2)=k(2)-2*q
#
else if (dt.eq.tb) then
q=-k(2)+ab*kk
p=BENDER_REF(3,obj,q,neui.s)
if (p.gt.0) k(2)=k(2)+2*q
#
endif
pp=pp*p
if (pp.lt.1.d-4) pp=0
if (pp.gt.0) then
dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
do i=1,3
k(i)=k(i)*kk/dum
enddo
# write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH
goto 50
endif
# CLOSE(15)
# if (PP.GT.0) then
# write(*,*) dname, 'error'
# pause
# endif
goto 300
199 continue
# CLOSE(15)
# if (PP.GT.0) then
# write(*,*) dname
# pause
# endif
200 continue
if (beta0.ne.0) then ! correction for beam deflection
delta0=0.5*obj.curv*obj.frame.size(3)**2
r2(1)=r(1)-r(3)*beta0+delta0
r2(3)=r(3)+r(1)*beta0
k(1)=k(1)-k(3)*beta0
k(3)=k(3)+k(1)*beta0
dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
do i=1,3 ! renormalize k
k(i)=k(i)*kk/dum
r(i)=r2(i)
enddo
endif
210 call SLIT_POST(obj.frame,r,k,neuf.r,neuf.k)
neuf.p=neui.p*pp
obj.frame.count=obj.frame.count+1
if(abs(obj.bint).gt.0.) then
dphi=gammal*obj.bint/obj.frame.size(3)*(neuf.t-tini)*1d-3
neuf.phi=neuf.phi+dphi
endif
BENDER_GO=.true.
return
300 continue
BENDER_GO=.false.
neuf.p=0
return
end
#
integer*4 FUNCTION READ_MIRROR(qc)
# read reflectivity data for supemirror (used in BENDER by NESS)
# *** J.S. 8/3/1999
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'nesobj_bender.inc'
integer*4 ierr,indx,i,j
real*8 mni,z,qc
character*3 suffix
character*9 fname
character*128 mirfile
mni=qc/gammani
READ_MIRROR=0
if(mni.lt.0) goto 200 ! clear all
if(mni.eq.0) goto 100
z=log10(mni)
if (z.lt.-1.or.z.ge.1) goto 100 ! must be 0.1 <= mNi < 10
1 format(f3.1)
write(suffix,1,err=2) mni
2 fname= 'mirror'//suffix
i=1
do while(i.le.m_nmax.and.m_name(i).ne.suffix.and.m_n(i).gt.0)
i=i+1
enddo
if (i.gt.m_nmax) goto 99
if (m_name(i).eq.suffix) then
READ_MIRROR=i
return
endif
indx=i
# OPEN(22,FILE=FNAME,STATUS='OLD',ERR=100)
call OPENRESFILE(fname, ' ',22,0,2,mirfile,ierr)
if(ierr.ne.0) goto 100
read(22,*,iostat=ierr,end=30,err=100)
i=0
do while(ierr.eq.0.and.(i.lt.128))
read(22,*,iostat=ierr,end=30,err=30)
* m_alpha(i+1,indx), m_ref1(i+1,indx),m_ref2(i+1,indx)
i=i+1
enddo
30 close(22)
m_n(indx)=i
m_name(indx)=suffix
3 format( 'reflectivity (',i1, ') read: ',a9, ' ,',i3, ' lines.')
write(sout,3) indx,fname,i
READ_MIRROR=indx
return
99 write(smes,*) 'Error: Lookup table for mirrors is full!'
READ_MIRROR=-1
return
100 READ_MIRROR=0
return
200 do j=1,m_nmax
do i=1,128
m_alpha(i,j)=i
m_ref1(i,j)=0
m_ref2(i,j)=0
enddo
m_n(j)=0
m_name(j)= ' '
enddo
READ_MIRROR=0
end
#////////////////// End of definition - BENDER ///////////////////
#---------------------------------------------------
SUBROUTINE BENDER_WRITE(iu,obj)
# Writes parameters of OBJ to unit U
#--------------------------------------------------
implicit none
INCLUDE 'nesobj_bender.inc'
integer*4 iu
record /BENDER/ obj
2 format( ' nlh,nlv : ',2(2x,i4))
3 format( ' w2,h2 : ',2(2x,f8.1))
4 format( ' crit. angles : ',6(2x,e12.3))
5 format( ' 1/R : ',e12.3)
6 format( ' dlh,dlv : ',2(2x,f8.3))
7 format( ' reflectivities : ',6(2x,f8.3))
8 format( ' int(B) : ',g12.5)
call SLIT_WRITE(obj.frame,iu)
write(iu,*)
write(iu,3) obj.w2, obj.h2
write(iu,2) obj.nlh,obj.nlv
write(iu,6) obj.dlh,obj.dlv
write(iu,4) obj.ghlu,obj.ghld,obj.ghru,obj.ghrd,
1 obj.gvt,obj.gvb
write(iu,7) obj.rhlu,obj.rhld,obj.rhru,obj.rhrd,
1 obj.rvt,obj.rvb
write(iu,5) obj.curv
write(iu,8) obj.bint
return
end