Source module last modified on Sat, 21 May 2005, 15:30;
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 - SLIT, SOURCE, DETECTOR
#////
#////
#//////////////////////////////////////////////////////////////////////
#
logical*4 FUNCTION INSIDE(obj,r)
#
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 r(3)
logical*4 log1
if (obj.shape.eq.3) then ! rectangle
log1=(
1 (abs(r(1)).lt.obj.size(1)/2.).and.
2 (abs(r(2)).lt.obj.size(2)/2.).and.
3 (abs(r(3)).lt.obj.size(3)/2.))
else if (obj.shape.eq.2) then ! disc
log1=(
1 (((r(1)*2./obj.size(1))**2+
2 (r(2)*2./obj.size(2))**2).lt.1).and.
3 (abs(r(3)).lt.obj.size(3)/2.))
else if (obj.shape.eq.1) then ! cylinder
log1=(
1 (((r(1)*2./obj.size(1))**2+
2 (r(3)*2./obj.size(3))**2).lt.1).and.
3 (abs(r(2)).lt.obj.size(2)/2.))
else if (obj.shape.eq.0) then ! ellipsoid
log1=(
1 ((r(1)*2./obj.size(1))**2+
2 (r(2)*2./obj.size(2))**2+
3 (r(3)*2./obj.size(3))**2).lt.1)
else
log1=.false.
end if
INSIDE=log1
# shape = 0 ... ellipsoid
# 1 ... vertical cylinder (axis//y)
# 2 ... disc plate (axis//z)
# 3 ... rectangular
return
end
#
SUBROUTINE SLIT_INIT(obj)
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 sta(3),pos(3),r(3,3),r0(3,3),r1(3,3),
1 r2(3,3),r3(3,3)
integer*4 i,j
#
pos(1)=0 ! position of the own axis vs. the preceding one
pos(2)=0
pos(3)=obj.dist
#/// POS = position of the object(=SLIT) vs. axis of the preceding object
#
do 10 i=1,3
pos(i)=obj.sta(i)+pos(i)
sta(i)=obj.sta(i)
10 continue
obj.count=0
# rot. matrix for AXI
do 20 i=1,3
do 20 j=1,3
if (i.eq.j) then
r2(i,j)=1
else
r2(i,j)=0
endif
20 continue
r2(1,1)=cos(obj.axi)
r2(3,3)=cos(obj.axi)
r2(1,3)=-sin(obj.axi)
r2(3,1)=+sin(obj.axi)
# rot. matrix for AXV
do 25 i=1,3
do 25 j=1,3
if (i.eq.j) then
r1(i,j)=1
else
r1(i,j)=0
endif
25 continue
r1(2,2)=cos(obj.axv)
r1(3,3)=cos(obj.axv)
r1(2,3)=+sin(obj.axv)
r1(3,2)=-sin(obj.axv)
# rotation matrix (R) for current axis with respect to the previous one
call M3XM3(1,r1,r2,r)
# rot. matrix for GON(1) around axis 2
do 30 i=1,3
do 30 j=1,3
if (i.eq.j) then
r1(i,j)=1
else
r1(i,j)=0
endif
30 continue
r1(1,1)=cos(obj.gon(1))
r1(3,3)=cos(obj.gon(1))
r1(1,3)=-sin(obj.gon(1))
r1(3,1)=+sin(obj.gon(1))
# rot. matrix for GON(2) around axis 1
do 40 i=1,3
do 40 j=1,3
if (i.eq.j) then
r2(i,j)=1
else
r2(i,j)=0
endif
40 continue
r2(2,2)=cos(obj.gon(2))
r2(3,3)=cos(obj.gon(2))
r2(2,3)=+sin(obj.gon(2))
r2(3,2)=-sin(obj.gon(2))
# rot. matrix for GON(3) around axis 2 again
do 50 i=1,3
do 50 j=1,3
if (i.eq.j) then
r3(i,j)=1
else
r3(i,j)=0
endif
50 continue
r3(1,1)=cos(obj.gon(3))
r3(3,3)=cos(obj.gon(3))
r3(1,3)=-sin(obj.gon(3))
r3(3,1)=+sin(obj.gon(3))
#/// two transformaton matrices are created:
#/// object vs. axis coordinates (ROT1)
#/// object vs. axis of the preceding object (ROT)
call M3XM3(1,r2,r1,r0)
call M3XM3(1,r3,r0,obj.rot1)
call M3XM3(1,obj.rot1,r,obj.rot)
do 60 i=1,3
obj.map(i)=.true.
if (1-abs(obj.rot(i,i)).lt.1.0d-8) obj.map(i)=0
obj.map1(i)=.true.
if (1-abs(obj.rot1(i,i)).lt.1.0d-8) obj.map1(i)=0
60 continue
# /// transform POS and STA to the object coordinates:
call M3XV3(1,obj.map1,obj.rot1,pos,obj.pos)
call M3XV3(1,obj.map1,obj.rot1,sta,obj.sta)
return
end
#
logical*4 FUNCTION SLIT_GO(obj,neui,neuf)
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
record /SLIT/ obj
record /NEUTRON/ neui,neuf
logical*4 log1,INSIDE
real*8 v(3),k(3),r(3)
integer*4 i
log1=(neui.p.gt.0.d0)
#/// At the begining, NEUI.R,K is in the axis coordinates of the
#
#/// NEUI.K and NEUI.R must be transformed to the object coordinates
#/// (including rotation and linear shift specified by GON(3) and STA(3):
call SLIT_PRE1(obj,neui.r,neui.k,v,k)
#/// move neutron to the centre of the OBJ:
neuf.t=neui.t-v(3)/hovm/k(3)
do 10 i=1,2
10 r(i)=v(i)-v(3)/k(3)*k(i)
r(3)=0.
if (INSIDE(obj,r)) then
#/// At the and, NEUF.K and NEUF.R must be in the axis coordinates
#/// of the object (i.e. without rotation and shift by GON(3) and STA(3))
# CALL SLIT_POST1(OBJ,R,K,NEUF.R,NEUF.K)
do i=1,3
neuf.r(i)=r(i)
neuf.k(i)=k(i)
end do
neuf.p=neui.p
neuf.s=neui.s
obj.count=obj.count+1
else
log1=.false.
neuf.p=0
end if
SLIT_GO=log1
return
end
# ////////////////// End of definition - SLIT ///////////////////
#
SUBROUTINE SLIT_POST(obj,r0,k0,r,k)
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3),v(3)
call V3AV3(1,r0,obj.sta,v)
call M3XV3(-1,obj.map1,obj.rot1,v,r)
call M3XV3(-1,obj.map1,obj.rot1,k0,k)
return
end
#
SUBROUTINE SLIT_POST1(obj,r0,k0,r,k)
#
# Use it if you are sure that STA=(0,0,0) and
# ROT1(2,2)=1 (=> ROT(i,2)=0)
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3)
r(1)=obj.rot1(1,1)*r0(1)+obj.rot1(3,1)*r0(3)
r(2)=r0(2)
r(3)=obj.rot1(1,3)*r0(1)+obj.rot1(3,3)*r0(3)
k(1)=obj.rot1(1,1)*k0(1)+obj.rot1(3,1)*k0(3)
k(2)=k0(2)
k(3)=obj.rot1(1,3)*k0(1)+obj.rot1(3,3)*k0(3)
return
end
#
SUBROUTINE SLIT_PRE(obj,r0,k0,r,k)
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3),v(3)
call M3XV3(1,obj.map,obj.rot,r0,v)
call M3XV3(1,obj.map,obj.rot,k0,k)
call V3AV3(-1,v,obj.pos,r)
return
end
#
SUBROUTINE SLIT_PRE1(obj,r0,k0,r,k)
#
# Use it if you are sure that POS(2)=0 and
#
#
implicit none
INCLUDE 'structures.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3)
r(1)=obj.rot(1,1)*r0(1)+obj.rot(1,3)*r0(3)
r(2)=r0(2)
r(3)=obj.rot(3,1)*r0(1)+obj.rot(3,3)*r0(3)
k(1)=obj.rot(1,1)*k0(1)+obj.rot(1,3)*k0(3)
k(2)=k0(2)
k(3)=obj.rot(3,1)*k0(1)+obj.rot(3,3)*k0(3)
r(1)=r(1)-obj.pos(1)
r(3)=r(3)-obj.pos(3)
return
end
# ////////////////// Definition of the SLIT object ///////////////////
#--------------------------------------------------
logical*4 FUNCTION DETECT_GO(det,neui,neuf)
# just a rectangular detector area, or,
# if DET.ALPHA>0 => ARRAY of cyllindrical detectors
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
logical*4 log1, SLIT_GO,SAM_BOARDER
real*8 kk,r(3),v(3),k(3),t1,t2,lam,z
real*8 p(0:64),ksi(0:64)
real*4 RAN1,rn,rn1
integer*4 i,j
record /DETECTOR/ det
record /NEUTRON/ neui,neuf
if(det.alpha.eq.0) then
log1=SLIT_GO(det.frame,neui,neuf)
else
rn=RAN1()
rn1=RAN1()
call SLIT_PRE(det.frame,neui.r,neui.k,v,k)
kk=sqrt(k(1)**2+k(2)**2+k(3)**2)
lam=2*pi/kk
p(0)=0.d0
ksi(0)=0.d0
do i=2,3
r(i)=v(i)
enddo
do j=1,det.nd
r(1)=v(1)+(det.frame.size(1)+det.space)*
& (j-(det.nd+1.d0)/2.d0)
if (SAM_BOARDER(det.frame,r,k,t1,t2)) then
ksi(j)=(t2-t1)*(rn+0.5)
p(j)=p(j-1)+(1.d0-exp(-det.alpha*lam*ksi(j)*kk))
else
p(j)=p(j-1)
ksi(j)=0.
endif
enddo
if (p(det.nd).lt.1.e-10) goto 99
z=p(det.nd)*(rn1+0.5)
j=0
do while (p(j).le.z.and.j.lt.det.nd)
j=j+1
enddo
do i=1,3
r(i)=v(i)+(t1+ksi(j))*k(i)
end do
call SLIT_POST(det.frame,r,k,neuf.r,neuf.k)
neuf.t=neui.t+(t1+ksi(j))/hovm
neuf.p=neui.p*p(det.nd)
neuf.s=neui.s
log1=(neuf.p.gt.0.d0)
if(log1) det.frame.count=det.frame.count+1
endif
DETECT_GO=log1
return
99 DETECT_GO=.false.
end