Source module last modified on Wed, 30 Mar 2005, 16:45;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#--------------------------------------------------------
logical*4 FUNCTION SPINMATCH(s,spin)
#// compares spin transfer with required value
#//// SPIN determines the combination of spin states required:
#//// -3 .... down --> down
#//// -1 .... down --> up
#//// 0 .... all
#//// +1 .... up --> down
#//// +3 .... up --> up
#--------------------------------------------------------
implicit none
real*4 s,spin
if(spin.eq.0) then
SPINMATCH=.true.
else
SPINMATCH=(nint(s).eq.nint(spin))
endif
end
#---------------------------------------------------------------
SUBROUTINE NSTORE
# Encapsulates procedures handling stack of neutron data
# Entries:
# _READ1(INDEX,NEU)
# _READ2(INDEX,I1,NEU)
# _WRITE1(INDEX,NEU)
# _WRITE2(INDEX,I1,NEU)
# _N(I1,I2,IALLOC)
# _ALLOCATE(INDEX)
# _FREE
# _GETQE(INDEX,QE,P,SP)
# _SETQE(INDEX,QE,P)
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
integer*4 nd,index,i,j,ierr,nmax,imax1,imax2,i1,i2,ialloc
parameter(nd=1000000)
record /NEUTRON/ neu
real*8 qe(4),vq(3),wq(3),kf0,ki0,vki(3),vkf(3),p
real*4 xx,sp
logical*4 SPINMATCH
#/ stores x,y,K(3),P,Spin for incident neutron
real, allocatable :: stack1(:,:)
#/ store index of inc. neutron + z,K(3),P,Spin for scattered neutron
real, allocatable :: stack2(:,:)
save stack1,stack2,nmax,imax1,imax2
ENTRY NSTORE_READ1(index,neu)
#--------------------------------------------------------
# Entry to read data of incident neutron
if(index.gt.nmax) goto 103
do i=1,2
neu.r(i)=1.*stack1(i,index)
enddo
do i=1,3
neu.k(i)=1.*stack1(i+2,index)
enddo
neu.p=1.*stack1(6,index)
neu.s=1.*stack1(7,index)
return
ENTRY NSTORE_WRITE1(index,neu)
#--------------------------------------------------------
# Entry to write data of incident neutron in STACK1(1:79)
# Stores R(2),K(3),PP,SPIN
ierr=0
if(index.gt.nmax) goto 102
do i=1,2
xx=neu.r(i)
stack1(i,index)=xx
enddo
do i=1,3
xx=neu.k(i)
stack1(i+2,index)=xx
enddo
xx=neu.p
stack1(6,index)=xx
xx=neu.s
stack1(7,index)=xx
if(index.gt.imax1) imax1=index
return
ENTRY NSTORE_WRITE2(index,i1,neu)
#--------------------------------------------------------
# Entry to write data of scattered neutron in STACK2(1:10)
# Stores I1,R(3),Q(3),E,PP,SPIN
# I1 is interpreted as an index to corresponding incident neutron in STACK1
ierr=0
if(index.gt.nmax) goto 102
if(index.gt.imax1) goto 105
xx=1.*i1
stack2(1,index)=xx
do i=1,3
xx=neu.r(i)
stack2(i+1,index)=xx
enddo
do i=1,3
vki(i)=stack1(i+2,i1)
vkf(i)=neu.k(i)
enddo
kf0=vkf(1)**2+vkf(2)**2+vkf(3)**2
ki0=vki(1)**2+vki(2)**2+vki(3)**2
#* subtract nominal values from k vectors
vkf(1)=vkf(1)-stp.kf*somega
vkf(3)=vkf(3)-stp.kf*comega
vki(3)=vki(3)-stp.ki
do i=1,3
vq(i)=vkf(i)-vki(i)
enddo
#* transform to C&N coord.
do i=1,3
wq(i)=0
do j=1,3
wq(i)=wq(i)+mlc(j,i)*vq(j)
enddo
enddo
do i=1,3
xx=wq(i)
stack2(i+4,index)=xx
enddo
xx=hsqov2m*(ki0-kf0)-stp.e
stack2(8,index)=xx
xx=neu.p*stack1(6,i1)
stack2(9,index)=xx
xx=2*nint(stack1(7,i1))+nint(neu.s)
stack2(10,index)=xx
if(index.gt.imax2) imax2=index
return
ENTRY NSTORE_N(i1,i2,ialloc)
#--------------------------------------------------------
# return number of allocated events
i1=imax1
i2=imax2
ialloc=nmax
return
ENTRY NSTORE_ALLOCATE(index)
#--------------------------------------------------------
# Entry for memory allocation
ierr=0
if(index.le.nmax) then ! no reallocation necessary
return
endif
if(index.gt.nd) goto 104 ! max. event number exceeded
if (allocated(stack1)) deallocate(stack1,stat=ierr)
if (ierr.ne.0) goto 98
if (allocated(stack2)) deallocate(stack2,stat=ierr)
if (ierr.ne.0) goto 98
nmax=0
imax1=0
imax2=0
allocate (stack1(1:7,1:index),stat=ierr)
allocate (stack2(1:10,1:index),stat=ierr)
if (ierr.ne.0) goto 99
nmax=index
return
ENTRY NSTORE_FREE
#--------------------------------------------------------
# Entry for memory deallocation
ierr=0
if (allocated(stack1))deallocate (stack1,stat=ierr)
if (ierr.ne.0) goto 98
if (allocated(stack2))deallocate (stack2,stat=ierr)
if (ierr.ne.0) goto 98
nmax=0
imax1=0
imax2=0
return
ENTRY NSTORE_GETQE(index,qe,p,sp)
#--------------------------------------------------------
# Entry to receive QE(4) vectors with appropriate weight
if(index.gt.nmax) goto 103
if (index.le.imax2.and.SPINMATCH(stack2(10,index),sp)) then
do i=1,3
qe(i)=stack2(i+4,index)
enddo
qe(4)=stack2(8,index)
if(index.eq.100) then
endif
p=stack2(9,index)
else
p=0.
endif
return
ENTRY NSTORE_SETQE(index,qe,p)
#--------------------------------------------------------
# Entry for setting QE(4) vector with weight
if(index.gt.nmax) goto 102
do i=1,4
stack2(i+4,index)=qe(i)
enddo
stack2(9,index)=p
stack2(10,index)=0.
return
97 format( 'NSTORE: ',a)
98 write(*,97) 'Deallocating memory for event storage: ',
* 'Error: ',ierr
stop
99 write(*,97) 'Allocating memory for event storage: ',
* 'Error: ',ierr, ' Amount: ',index
stop
102 write(*,97) 'Error: Attempt to write to a nonallocated arrea ! '
* ,index
stop
103 write(*,97) 'Attempt to read from a nonallocated arrea ! '
* ,index
stop
104 write(*,97) 'Max.',nd, ' events can be stored'
stop
105 write(*,97) 'Nonexistent incident neutron referenced: ',i1
stop
end
#--------------------------------------------------------
SUBROUTINE EVARRAY(icom,ia,index,x,val)
# VMS version of the EVARRAY routine for HP-UX
# which handles dynamically allocated arrays EVA(5,:)
#/// ICOM=-1 deallocate
#/// ICOM=0 allocate
#/// ICOM=1 writes X(4),VAL to the INDEX's row of EVA
#/// ICOM=2 reads X(4),VAL from the INDEX's row of EVA
#/// ICOM=3 INDEX= max. allocated row of EVA
#--------------------------------------------------------
implicit double precision (a-h,o-z)
parameter(nd=500000)
real eva(5,nd),eva1(5,nd)
real*8 x(4)
integer*4 index
save eva,eva1,imax,imax1
if(ia.eq.0) then
if(icom.eq.2) then
if (index.le.imax) then
do i=1,4
x(i)=eva(i,index)
end do
val=eva(5,index)
else
pause 'Attempt to read from a nonallocated arrea !'
endif
return
else if(icom.eq.1) then
if (index.le.imax) then
do i=1,4
eva(i,index)=x(i)
end do
eva(5,index)=val
else
pause 'Attempt to write to a nonallocated arrea !'
endif
return
else if(icom.eq.0) then
if(index.gt.nd) then
index=nd
imax=nd
write(*,*) 'Maximum number of events is ',nd
endif
imax=index
else if(icom.eq.3) then
index=imax
return
endif
else if(ia.eq.1) then
if(icom.eq.2) then
if (index.le.imax1) then
do i=1,4
x(i)=eva1(i,index)
end do
val=eva1(5,index)
else
pause 'Attempt to read from a nonallocated arrea !'
endif
return
else if(icom.eq.1) then
if (index.le.imax1) then
do i=1,4
eva1(i,index)=x(i)
end do
eva1(5,index)=val
else
pause 'Attempt to write to a nonallocated arrea !'
endif
return
else if(icom.eq.0) then
if(index.gt.nd) then
index=nd
imax1=nd
write(*,*) 'Maximum number of events is ',nd
endif
imax1=index
else if(icom.eq.3) then
index=imax1
return
endif
endif
if(icom.eq.-1) then
imax=0
imax1=0
return
endif
return
end