src/ness/ness_nstore.f

Fortran project SIMRES, source module src/ness/ness_nstore.f.

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