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 for object: SLIT ****
#////
#//// SLIT is parent type for all NESS components
#//// (i) routines must be defined in any descendant
#////
#//// ** I/O routines **
#////i SUBROUTINE SLIT_CMD(OBJ)
#////i SUBROUTINE SLIT_WRITE(OBJ,IU)
#////i INTEGER*4 FUNCTION SLIT_READ(OBJ,IU,IERR)
#////i INTEGER*4 FUNCTION SLIT_SET(OBJ,source)
#////i CHARACTER*(*) FUNCTION SLIT_GET(OBJ,iwhat)
#////
#//// ** M.C. routines **
#////i SUBROUTINE SLIT_INIT(OBJ)
#////i LOGICAL*4 FUNCTION SLIT_GO(OBJ,NEUI,NEUF)
#////
#//// LOGICAL*4 FUNCTION INSIDE(OBJ,R)
#//// SUBROUTINE SLIT_PRE(OBJ,R0,K0,R,K)
#//// SUBROUTINE SLIT_POST(OBJ,R0,K0,R,K)
#//// SUBROUTINE SLIT_PRE1(OBJ,R0,K0,R,K)
#//// SUBROUTINE SLIT_POST1(OBJ,R0,K0,R,K)
#////
#//////////////////////////////////////////////////////////////////////
#******************* I/O routines *********************
# ------------------------------------------------
SUBROUTINE SLIT_WRITE(obj,iu)
# write all setup to IU
# ------------------------------------------------
implicit none
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
character*128 SLIT_GET
integer*4 iu,i
1 format(a)
write(iu,1) '['//t_slit// ']'
do i=1,nlist
call WRITELINE(slitcomm(i)// ' '//SLIT_GET(obj,i),iu)
enddo
write(iu,1) 'END '//obj.name
end
# ----------------------------------------------------
integer*4 FUNCTION SLIT_READ(obj,iu,ierr)
# read all setup from IU (input must end with 'END' command)
# Returns number of read lines, error code is in IERR
# ----------------------------------------------------
implicit none
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
character*128 source
integer*4 SLIT_SET
integer*4 iu,ierr,iline
1 format(a)
ierr=0
iline=0
source= ' '
do while (source(1:3).ne. 'END'.and.ierr.eq.0)
read(iu,1,err=100,iostat=ierr) source
ierr=SLIT_SET(obj,source)
call MKUPCASE(source(1:3))
if (ierr.eq.0) iline=iline+1
enddo
100 SLIT_READ=iline
end
# ------------------------------------------------
integer*4 FUNCTION SLIT_SET(obj,source)
# ------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj,dum
character*(*) source
character*128 values
integer*4 i,j,ORDCOM,ierr,s,l
ierr=0
#*** find first parameter as variable name
s=1
1 format(a)
call FINDPAR(source,1,s,l)
SLIT_SET=0
if (l.le.0) return ! ignore empty string
values=source(s+l:len(source))
i=ORDCOM(source(s:s+l-1),slitcomm,nlist)
if(i.gt.0.and.i.le.6) then
dum=obj
call BOUNDS(values,s,l)
values=values(s:s+l-1)
if (i.eq.1) then
read(values,1,err=100,iostat=ierr) obj.name
else if (i.eq.2) then
read(values,*,err=100,iostat=ierr) (obj.size(j),j=1,3)
else if (i.eq.3) then
read(values,*,err=100,iostat=ierr) obj.shape
else if (i.eq.4) then
read(values,*,err=100,iostat=ierr) obj.dist,obj.axi,
* obj.axv
obj.axi=obj.axi/rad
obj.axv=obj.axv/rad
else if (i.eq.5) then
read(values,*,err=100,iostat=ierr) (obj.gon(j),j=1,3)
do j=1,3
obj.gon(j)=obj.gon(j)/rad
enddo
else if (i.eq.6) then
read(values,*,err=100,iostat=ierr) (obj.sta(j),j=1,3)
endif
endif ! ignores any other string not recognized as variable
if (ierr.ne.0) then
obj=dum
ierr=-1 ! IO warning
endif
SLIT_SET=ierr
return
100 SLIT_SET=-2 ! IO error
obj=dum
end
# ------------------------------------------------
character*(*) FUNCTION SLIT_GET(obj,iwhat)
# ------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
character*128 target
integer*4 j,iwhat
1 format(a)
2 format(3(g13.5,1x))
3 format(i5)
target= ' '
if (iwhat.gt.0.and.iwhat.le.6) then
if (iwhat.eq.1) then
write(target,1) obj.name
else if (iwhat.eq.2) then
write(target,2) (obj.size(j),j=1,3)
else if (iwhat.eq.3) then
write(target,3) obj.shape
else if (iwhat.eq.4) then
write(target,2) obj.dist, obj.axi/deg,obj.axv/deg
else if (iwhat.eq.5) then
write(target,2) (obj.gon(j)/deg,j=1,3)
else if (iwhat.eq.6) then
write(target,2) (obj.sta(j),j=1,3)
endif
else
SLIT_GET= ' '
endif
SLIT_GET=target
end
#********************* M.C. routines **************************
#
logical*4 FUNCTION INSIDE(obj,r)
#
#
implicit none
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
real*8 r(3)
logical*4 log1
if (obj.shape.eq.3) then ! rectangle
log1=(
1 (abs(r(1)).le.obj.size(1)/2.).and.
2 (abs(r(2)).le.obj.size(2)/2.).and.
3 (abs(r(3)).le.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).le.1).and.
3 (abs(r(3)).le.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).le.1).and.
3 (abs(r(2)).le.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).le.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 'nesobj_slit.inc'
record /SLIT/ obj
real*8 sta(3),pos(3),r(3,3),r1(3,3),r2(3,3),r3(3,3),aux(3,3)
real*8 dum ! ,DETERM
logical*4 map0(3)
integer*4 i,j
data map0 /.true.,.true.,.true./
# 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))
#/// 3 transformaton matrices were created:
#/// axis vs. preceding axis (R)
#/// object vs. axis (OBJ.ROT1=R3*R2*R1)
#/// object vs. preceding axis (OBJ.ROT=ROT1*R)
call M3XM3(1,r2,r1,aux)
call M3XM3(1,r3,aux,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)=.false.
obj.map1(i)=.true.
if (1-abs(obj.rot1(i,i)).lt.1.0d-8) obj.map1(i)=.false.
60 continue
do i=1,3
pos(i)=obj.sta(i)
sta(i)=obj.sta(i)
enddo
pos(3)= obj.sta(3)+obj.dist
# /// transform POS and STA to the object coordinates:
call M3xV3_M(1,obj.map1,obj.rot1,pos,obj.pos)
call M3xV3_M(1,obj.map1,obj.rot1,sta,obj.sta)
obj.count=0 ! counter reset to zero
dum=0
obj.simple=.false.
do i=1,3
dum=dum+abs(obj.sta(i))
dum=dum+abs(obj.gon(i))
enddo
if(dum+abs(obj.axv).eq.0) obj.simple=.true.
# write(*,*) OBJ.NAME
# write(*,*) POS
# write(*,*) OBJ.POS
# write(*,*) DETERM(R,3,AUX)
# write(*,*) DETERM(OBJ.ROT,3,AUX),DETERM(OBJ.ROT1,3,AUX)
# write(*,*) DETERM(R1,3,AUX),DETERM(R2,3,AUX),DETERM(R3,3,AUX)
# pause
return
end
#
logical*4 FUNCTION SLIT_GO(obj,neui,neuf)
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
record /NEUTRON/ neui,neuf
integer*4 i
logical*4 log1,INSIDE
real*8 v(3),k(3),r(3)
log1=.true.
#/// 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):
neuf=neui
call SLIT_PRE(obj,neui.r,neui.k,v,k)
#/// move neutron to the centre of the SLIT:
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_POST(obj,r,k,neuf.r,neuf.k)
obj.count=obj.count+1
else
log1=.false.
neuf.p=0
end if
SLIT_GO=log1
return
end
#
#
SUBROUTINE SLIT_PRE(obj,r0,k0,r,k)
#
implicit none
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3),v(3)
#/// Neutron variables are originaly expressed in previous axis coordinates.
#
if (.not.obj.simple) then
#
call M3xV3_M(1,obj.map,obj.rot,r0,v)
call M3xV3_M(1,obj.map,obj.rot,k0,k)
call V3AV3(-1,v,obj.pos,r)
else
r(1)=obj.rot(1,1)*r0(1)+obj.rot(1,3)*r0(3)-obj.pos(1)
r(2)=r0(2)
r(3)=obj.rot(3,1)*r0(1)+obj.rot(3,3)*r0(3)-obj.pos(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)
endif
return
end
#
SUBROUTINE SLIT_POST(obj,r0,k0,r,k)
#
implicit none
INCLUDE 'nesobj_slit.inc'
record /SLIT/ obj
real*8 r0(3),k0(3),r(3),k(3),v(3)
integer*4 i
#
if (.not.obj.simple) then
call V3AV3(1,r0,obj.sta,v)
call M3xV3_M(-1,obj.map1,obj.rot1,v,r)
call M3xV3_M(-1,obj.map1,obj.rot1,k0,k)
else
do i=1,3
k(i)=k0(i)
r(i)=r0(i)
enddo
endif
return
end