src/simres_main.f

Fortran project SIMRES, source module src/simres_main.f.

Source module last modified on Mon, 23 May 2005, 11:52;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


#////////////////////////////////////////////////////////////////////////
#
#                 ************************************ 
#                 ***                              *** 
#                 ***        S I M R E S           *** 
#                 ***            (PWD)             ***
#                 ***   (C) J.Saroun & J.Kulda     *** 
#                 ***        ILL Grenoble          ***
#                 ***      evaluation version      ***
#                 ************************************ 
#
# A clone of RESTRAX: http://omega.ujf.cas.cz/restrax
#
# Provides more flexible (and more realistic) ray-tracing code useful for simulation 
# of newly designed or upgraded instruments and optimisation of their configuration. 
# This version permits to simulate intensity and distribution of neutron beam in both 
# real and momentum subspaces at different positions along the TAS beamline. 
# Arrangements derived from TAS setup can also be simulated - they involve e.g. powder
# diffractometers equipped with multidetectors, neutron guides or different configurations 
# of primary spectormeter (i.e. crystal monochromator with series of collimator or 
# guide segments).
# 
#****************************************************************************
# *** For all additional information contact the authors:                 ***
# ***                                                                     ***
# ***                 kulda@ill.fr        saroun@ujf.cas.cz               ***
# ***                                                                     ***
#****************************************************************************

#***********************************************************
#
# ONLY M.C. SIMULATION OF NEUTRON FLUX IN THIS VERSION !!!
#
#***********************************************************
#-------------------------------------
      SUBROUTINE RESTRAX_MAIN
# Main unit for console application
#-------------------------------------
      implicit none
      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'
      INCLUDE 'linp.inc'
      character*(128) line
      character*1 ch
      integer*4 l
1     format(a)
2     format(a,$)
      
      call CMD_HANDLE( 'SETLINP')      
      do while (.true.)
10      if (linp_in.eq.5) write(linp_out,2) linp_p(1:linp_np)// '> ' 
        if (linp_eof.gt.0) goto 20
        read(sinp,1,end=20) line  ! treat EOF
        ch=line(1:1)
        if (ch.eq. '#'.or.ch.eq. ' '.or.ch.eq.char(0)) goto 10
        l=len(line)
        call CMD_HANDLE(line(1:l))
        goto 10        
20      call REINP( ' ')
        call REOUT( ' ' ! end of job file -> close also output file
        call LINPSETIO(sinp,sout,smes)
      enddo
      
      end

#-------------------------------------------------------------
      SUBROUTINE BEFORE(ierr)
#  Call whenever the setup may have changed
#  Updates calculated auxilliary fields   
#  eturns IRES=0, if everything is OK 
#------------------------------------------------------------- 
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'trax.inc'
      integer*4 ier,ierr
      common /error/ier
      real*8 z,z1,co,si
# look on the commons for collimators at a more convenient scope
      integer*4 ncol(4),i,j
      real*8 vlc(6,4)
      equivalence (ncol(1),nfm)
      equivalence (vlc(1,1),vlcanm)
      
# ATTENTION : order of following routines may be important !!!
      ier=0

#///  scattering triangle in STP record
      stp.nfx=res_dat(i_fx)
      stp.sm=res_dat(i_sm)
      stp.ss=res_dat(i_ss)
      stp.sa=res_dat(i_sa)
      stp.kfix=res_dat(i_kfix)
      if (stp.nfx.eq.1.) then
         stp.ei0=hsqov2m*stp.kfix**2
         stp.ef0=stp.ei0-res_dat(i_en)
      else
         stp.ef0=hsqov2m*stp.kfix**2
         stp.ei0=stp.ef0+res_dat(i_en)
      end if                                      
      stp.ki=sqrt(stp.ei0/hsqov2m)
      stp.kf=sqrt(stp.ef0/hsqov2m)

      call QNORM(qhkl,z,z1)
      stp.q=z1
      stp.e=hsqov2m*(stp.ki**2-stp.kf**2)
      
#// scattering angle 
      if (stp.q.eq.0) then
        comega=1
        somega=0
        omega=0
      else        
        comega=-(stp.q**2-stp.ki**2-stp.kf**2)/(2*stp.ki*stp.kf)
        if(abs(comega).gt.1) goto 999
        somega=sign(1,stp.ss)*sqrt(1-comega**2)
        omega=asin(somega)
        if (comega.lt.0) omega=sign(1,stp.ss)*pi-omega
      endif

#///  trans. matrix CN->lab
      do 60 i=1,3
      do 60 j=1,3
         mlc(i,j)=0.
60    continue
      if (stp.q.eq.0) then
        co=1
        si=0
      else              
        co=(stp.kf**2-stp.ki**2-stp.q**2)/(2*stp.ki*stp.q)
        if(abs(co).gt.1) goto 999
        si=sign(1,stp.ss)*sqrt(1-co**2)
      endif  
      mlc(1,1)=si
      mlc(1,2)=co
      mlc(2,3)=1.
      mlc(3,1)=co
      mlc(3,2)=-si

#// transformation matrices
      call RECLAT           !   compute reciprocal lattice parameters and matrices
      call TRANSMAT         !   create transformation matrices for coordinate systems
      
#  collimator parameters from TRAX
# ////   if ALPHA(I)<500  then the coarse collimator is ignored
# ////   if ALPHA(I)>=500 then the Soller collimator is ignored 
# ////   if ALPHA(I)=0 then no collimation is considered

      do i=1,4
        alpha(i)=res_dat(i_alf1+i-1)
        beta(i)=res_dat(i_bet1+i-1)
        ncol(i)=-1
        if (alpha(i).ge.500.and.vlc(2,i).ne.0) then
          alpha(i)=0.
          ncol(i)=1
        endif
      enddo 

      ierr=ier
      return
 
      
999   ierr=1              
      end                                 
                         
#-----------------------------
      SUBROUTINE LOGO
#----------------------------- 
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'config.inc'

1     format(2x, '-----------------------------------------------',/,
     &       2x, 'S I M R E S  - Monte Carlo ray-tracing ',/,
     &       2x, 'Version: ',a40,/,
     &       2x, 'Build:   ',a40,/,
     &       2x, '-----------------------------------------------',/,
     &       2x, '(C) J.Saroun & J.Kulda',/,
     &       2x, 'ILL Grenoble, NPI Rez near Prague',/,
     &       2x, ' ',/,
     &       2x, '-----------------------------------------------',/,
     &       2x, 'type ? for command list',/,/)
     

      write(sout,1) package_version,package_date  
      return
      end

#***********************************************************************
        SUBROUTINE UNITS(sarg)
#***********************************************************************
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) sarg
      character*1 ch

1     format( ' Energy In m[eV] Or T[Hz]? (meV) ',$)
2     format( 'THz')
5     format( 'meV')
3     format(a)
4     format( ' Units are ',a)
        
      ch=sarg(1:1)
      if(ch.eq. ' ') then
        write(smes,1)
        read(sinp,3) ch
        call MKUPCASE(ch)
      endif  
      if(ch.eq. 'T') then
          euni=0.24181
          write(cunit,2)
      else
          euni=1.
          write(cunit,5)
      endif
      write(sout,4) cunit
      end
#
#

#-----------------------------------------------------------        
      SUBROUTINE GETROANAL(ro)
# return "optimal" monochromator and analyzer curvatures 
# calculated analytically
# *** J.S. 3/6/1997     
#-----------------------------------------------------------      

      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'trax.inc'
      INCLUDE 'rescal.inc'

      real*4 ro(4)
      real*8 thm,chim,tha,chia
 
      thm=pi/sqrt(stp.ei0/hsqov2m)/res_dat(i_dm)
      thm=abs(asin(thm))
      chim=himon*deg      
      tha=pi/sqrt(stp.ef0/hsqov2m)/res_dat(i_da)
      tha=abs(asin(tha))
      chia=hiana*deg
#      RO(1)=SIN(THM+CHIM)/2./VL1*100
# change to monochromatic focusing:
      ro(1)=sin(thm+chim)/vl1*100
#      write(*,*) 'VL1, THM, CHIM: ',VL1,THM*180/PI,CHIM*180/PI
      ro(2)=1./vl1/(2.*sin(thm)*cos(chim))*100
#      RO(3)=(VL2*SIN(THA+CHIA) + VL3*SIN(THA-CHIA))/2./VL2/VL3*100
      ro(3)=sin(tha-chia)/vl2*100
      ro(4)=(1./vl2+1./vl3)/(2.*sin(tha)*cos(chia))*100
      end

          
#-----------------------------------------------------------        
      SUBROUTINE GETRO
# generates "optimal" monochromator and analyzer curvatures      
#-----------------------------------------------------------                    
      implicit none
      INCLUDE 'inout.inc'
      include 'rescal.inc'

      real*4 ro(4)
      integer*4 i
      character*10 remark(4)
            
1     format(1x,a4, ' = ',f8.4, ' [m-1] ',a10)
                 
      call GETROANAL(ro)
      do i=1,4
        remark(i)= ' '
        if((nos.eq.0).or.((nos.ge.i).and.(ret(i).eq.1.))) then
           res_dat(i_romh+i-1)=ro(i)
           remark(i)= ' changed'
        endif
        write(sout,1) res_nam(i_romh+i-1),ro(i),remark(i)   
      enddo
            
      end


#-----------------------------------------------------------        
      SUBROUTINE GETROOPTMC
# Optimize curvature with M.C. simulation
# Only one of the curvatures can be optimized  
# *** J.S. 5/7/2001     
#-----------------------------------------------------------      
              
      implicit none
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'

      real*4 ro(4)
      integer*4 ierr,i
      common /error/ierr
      integer*4 optpar,optmerit
      real*8 optev
      common /mcoptim/ optpar,optmerit,optev
      real*4 OPTMC,par(1),tol,dpar(1) 
      external OPTMC
      logical*4 verbose
      integer*4 nev
      common /mcsetting/ verbose,nev

           
1     format(1x,a4, ' = ',f8.4, ' [m-1] ',a10)
5     format( ' Numerical optimization failed ! '
6     format( ' Wrong syntax. Type> MRO n [e] ',/,
     *   'n=1 to 4 for ROMH, ROMV, ROAH, ROAV',/,
     *   'e   .. number of events in 1000 (default e=1)'
                 
7     format( ' (1) Incident flux',/,
     *        ' (2) flux/dE ',/,
     *        ' (3) flux/dE^2 ',/,
     *        ' (4) Powder peak (detector with Soller)',/,
     *        ' (5) Powder peak (position-sensitive detector) ',/,
     *        ' (6) Vanad peak ',/,
      'Select figure of merit: ',$)


20    write(*,7)
      read(sinp,*) i
      if(i.lt.1.or.i.gt.6) goto 20     
      optmerit=i
#      WRITE(*,*) OPTMERIT
      
      call NESS_CONV(1)
      
      call GETROANAL(ro)   ! Analytical estimation    
      optpar=nint(ret(1))
      if (nos.gt.1) then
        optev=ret(2)
      else
        optev=1.0        
      endif        
      if(optpar.lt.0.or.optpar.gt.4.or.nos.lt.1) then
         write(sout,6)
         return
      endif
      
      tol=0.1
      dpar(1)=0.05  ! minimum increment for vert. curvature = 0.05m^-1
      if (optpar.eq.1.or.optpar.eq.3) dpar(1)=0.01  ! 0.01m^-1 for hor. curv.
      par(1)=ro(optpar)
#      VERBOSE=.FALSE.
      call LMOPT(OPTMC,par,1,tol,dpar,0)
#      VERBOSE=.TRUE.
      if (ierr.ne.0) then
         write(sout,5)
         return
      endif         

      res_dat(i_romh+optpar-1)=par(1)
      write(sout,1) res_nam(i_romh+optpar-1),res_dat(i_romh+optpar-1),
      ' changed'   
                            
      return
      end
      
#
#
#
#***********************************************************************
      SUBROUTINE SAM_FLUX(icom)
# /// simulate flux at the sample (arg<>2) or at the detector (arg=2)
# /// by forward method (ICOM=1) or "from the sample" (ICOM=0)
# /// ICOM=2- monitor at position RET(1)      
#***********************************************************************
#
      implicit none
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      integer*4 icom
              
#// monitor 
      if (icom.eq.2) then
        call NESS_CONV(1)
        imonit=nint(ret(1))
        if (imonit.le.7) then 
           call NESS(7,0.d0)
        else
           call NESS(6,0.d0)
        endif   
        imonit=-1
        return
      endif
      
#// no monitor
      imonit=-1
      call NESS_CONV(1)
      if (icom.eq.3) then    ! TAS 
         call NESS(8,0.d0)
      else if (icom.eq.4) then   ! PWD
         call NESS(9,0.d0)
      else if (icom.eq.5) then   ! PWDS
         call NESS(10,0.d0)
#// FLUX   (ICOM=1) or NFLUX (ICOM=0) command:
      else          
         if (ret(1).eq.2) then       ! powder - PSD
           call NESS(4+icom,0.d0)
         else if (ret(1).eq.3) then  !  TAS
           call NESS(1,0.d0) 
         else if (ret(1).eq.4) then  !  TAS forward
           ftas=1
           call NESS(1,0.d0)
           ftas=0 
         else if (ret(1).eq.11) then  !  double cryst. (bragg scattering)
           call NESS(11,0.d0) 
         else                        ! flux at the sample
           call NESS(2+icom,0.d0)
         endif
      endif 
      return
      end                   
        
#***********************************************************************
      SUBROUTINE SCAN_CHI(icom)
# Make a scan with monochromator cutting angle   
# arguments are STEP [deg], NSTEPS, [NEVENTS] 
# simulates powder diffration
#***********************************************************************
#
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'trax.inc'
      
      integer*4 icom,nchi,i
      real*4 ev,dchi,chi0
        
1     format( 'CHI = ',g12.6)      

      if (nos.ge.2) then
        call NESS_CONV(1)
        chi0=himon
        dchi=ret(1)
        nchi=nint(ret(2))
        ev=10.d0
        if(nos.ge.3) ev=ret(3)  ! number of events
        if (nchi.gt.100) nchi=100
        if (nchi.lt.1) nchi=1
        do i=1,nchi
          himon=chi0+(i-(nchi+1)/2)*dchi
          call NESS_CONV(0)         
          write(sout,1) mon.chi*180/pi
          call NESS(9,-abs(ev))
        enddo
        himon=chi0
        call NESS_CONV(0)         
      endif  
      end

#***********************************************************************
      SUBROUTINE SCAN_TAS
# /// simulate standard TAS scan (DH,DK,DL,DE)
#//// using scattering cross-section defined by SQE_AMAG funciton
# accepts 4 arguments:
# a1 ... number of steps (obligatory) 
# a2 ... number of events (x1000) , default=10 
# a3 ... time (~monitor counts), default=100 
# a4 ... background (in cnts), default=0
#***********************************************************************
#
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'rescal.inc'
        
      integer*4 i,j,nstp
      real*8 ev,monef
      parameter(monef=1d-8)
            
      real*8 cnts(128),cntd(128),cnte(128),ki(128),time,bcg
      real*8 qhkl0(4),k0     
      real*4 GASDEV
            
1     format(i3,2x,4(g10.4,1x),2(g12.4,2x))      
2     format( 'PNT   QH   QK   QL   EN   CNTS  MON')      
3     format( 'PNT   QH   QK   QL   EN   CNTS  TIME')      

      if (nos.ge.1) then
        k0=stp.ki
        call NESS_CONV(1)
        do j=1,4
          qhkl0(j)=qhkl(j)
        enddo
#        WRITE(SOUT,1) (QHKL0(J),J=1,4)
#        pause
        nstp=nint(ret(1))
        ev=10.d0
        if(nos.ge.2) ev=ret(2)  ! number of events
        time=100.d0
        if(nos.ge.3) time=ret(3)  ! time
        bcg=0.d0
        if(nos.ge.4) bcg=ret(4)  ! background
        if (nstp.gt.100) nstp=100
        if (nstp.lt.1) nstp=1
        write(sout,2)
        do i=1,nstp
          do j=1,4
            qhkl(j)=qhkl0(j)+(i-(nstp+1)/2)*delq(j)
          enddo            
          call NESS_CONV(1)         
          call NESS(8,abs(ev))
          cnts(i)=iinc
          cntd(i)=time*i3ax
          cnte(i)=time*di3ax
          ki(i)=stp.ki
          write(sout,1) i,(qhkl(j),j=1,4),cntd(i),cnts(i) 
        enddo
        do j=1,4
          qhkl(j)=qhkl0(j)
        enddo        
        call NESS_CONV(1)         
        do i=1,nstp
          spcx(i)=qhkl0(4)+(i-(nstp+1)/2)*delq(4)
          spcy(i)=cntd(i)/cnts(i)/monef  ! normalize to monitor counts
          spcd(i)=cnte(i)/cnts(i)/monef
        enddo
        write(sout,3)
        do i=1,nstp
          if (bcg.gt.0) then  ! add const. background and errors
            spcy(i)=spcy(i)+bcg
            spcd(i)=sqrt(abs(spcy(i))+spcd(i)**2)
            spcy(i)=spcy(i)+sqrt(abs(spcy(i)))*GASDEV()
          endif  
          
          write(sout,1) i,(qhkl0(j)+(i-(nstp+1)/2)*delq(j),j=1,4),
     *                   spcy(i),time/monef/cnts(i)*ki(i)
        enddo
        spcn=nstp
      endif  
      end

#***********************************************************************
      SUBROUTINE SCAN_THETA
# /// simulate standard TAS scan (A1,A2,A3,A4,A5,A6)
# accepts 4 arguments:
# a1 ... number of steps (obligatory) 
# a2 ... number of events (x1000) , default=10 
# a3 ... time (~monitor counts), default=100 
# a4 ... background (in cnts), default=0
#***********************************************************************
#
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      integer*4 mf
      parameter (mf=65)
      integer*4 nstp
      real*8 ev,monef
      parameter(monef=1d-8)
      
      integer*4 i_io
      character*128 line
      character*50 filename
      real*8 ar(6)
      integer*4 na,ia(6),iwhat,k,i,j
      real*4 fx(mf),fy(mf),dfy(mf),fy1(mf),dfy1(mf)
      real*8 cnts(128),cntd(128),cnte(128),time
            
4     format( 'A',i1, '      ',$)      
5     format(g10.4,1x,$)
55    format(2(g10.4,1x))      
6     format( 'Axes [1..6]: ',$)
7     format(a)      
8     format( 'Steps [min]: ',$)
9     format( '(1) Sample, (2) Powder, (3) Double-Crystal, (4) TAS :',$)
44     format(1x,4(2x,e13.5))

      if (nos.lt.1) then
        write(sout,*)  'Use number of points as the 1st argument'
        return
      endif  
      write(sout,9) 
      read(sinp,*) iwhat
      if (iwhat.eq.4) then
        call SCAN_TAS
        return
      else if (iwhat.lt.1.or.iwhat.gt.4) then
        write(*,*)  'UNDEFINED TASK: ',iwhat 
        return  
      endif
#// initialize
        call NESS_CONV(1)
        do j=1,6
          dthax(j)=0.
          ia(j)=j
          ar(j)=0.
        enddo
#// interpret arguments
        nstp=nint(ret(1))
        ev=10.d0
        if(nos.ge.2) ev=ret(2)  ! number of events
        time=1.d0
        if(nos.ge.3) time=ret(3)  ! time
        if (nstp.gt.101) nstp=101
        if (nstp.lt.1) nstp=1
#// read angular steps from input        
        write(sout,6) 
        read(sinp,7) line    ! read axes indexes
        call GETLINPARG(line,ar,6,na)
        do i=1,na
          ia(i)=int(ar(i))
          if(ia(i).gt.6.or.ia(i).le.0) ia(i)=0
        enddo  
        write(sout,8) 
        read(sinp,7) line   ! read axes steps
        
        call GETLINPARG(line,ar,6,j) 
        if (j.ne.na) then
          write(*,*)  'EACH AXIS MUST HAVE A STEP DEFINED !!'
        endif
          do i=1,na
             write(sout,4) ia(i) 
          enddo
          write(sout,*)
          do i=1,na
             write(sout,5) ar(i) 
          enddo
          write(sout,*)
#// get only valid steps
        k=0
        do i=1,na
          if (ia(i).ne.0.and.ar(i).ne.0) then
             k=k+1
             ar(k)=ar(i)
             ia(k)=ia(i)
             write(sout,4) ia(i)   ! write header
          endif               
        enddo
        na=k
        write(sout,*)  'CNTS    ERR' 
        do j=1,mf
          fy1(j)=0
          dfy1(j)=0            
        enddo

#// Start scan
        do i=1,nstp
          do j=1,na
            dthax(ia(j))=(i-(nstp+1)/2)*ar(j) 
          enddo
          do j=1,na
            write(sout,5) dthax(ia(j)) 
          enddo
          call NESS_CONV(0) 
          if (iwhat.eq.1) then        
              call NESS(2,abs(ev)) 
              cntd(i)=time*iinc
              cnte(i)=time*diinc
          else if (iwhat.eq.2) then 
              call NESS(4,abs(ev)) 
              cntd(i)=time*ipwd
              cnte(i)=time*dipwd
          else if (iwhat.eq.3) then 
              call NESS(11,abs(ev)) 
              cntd(i)=time*i3ax
              cnte(i)=time*di3ax
          endif              
          cnts(i)=iinc
          write(sout,55) cntd(i),cnte(i)
          call PSD_ARRAY(fx,fy,dfy,mf)
          do j=1,mf
            fy1(j)=fy1(j)+fy(j)
            dfy1(j)=dfy1(j)+dfy(j)**2            
          enddo
        enddo
#// End scan, reset configuration
        do j=1,mf
            dfy1(j)=sqrt(dfy1(j))            
        enddo
        do j=1,6
          dthax(j)=0.
        enddo
        call NESS_CONV(0)   
#// save integrated profile at the PSD        
      i_io=22
      filename= ' '
12    format(a50)
13    format( ' PSD data output: ',$)
      write(sout,13)
      read(sinp,12) filename

      if(filename(1:1).eq. ' '.or.filename(1:1).eq.char(0)) then   ! generate automatic filename
        goto 200
      else
        open(unit=i_io,file=filename,err=999,status= 'Unknown')
        write(i_io,*)  'X      INT       ERR    '
        do i=1,mf
          write(i_io,44) fx(i),fy1(i),dfy1(i) 
        enddo  
        close(i_io)
      endif
             
#// Fill arrays with results
200        do i=1,nstp
          spcx(i)=(i-(nstp+1)/2)*ar(1)
          spcy(i)=cntd(i)
          spcd(i)=cnte(i)
        enddo
#// List data
        do j=1,na
          write(sout,4) j 
        enddo
        write(sout,*)  'CNTS    ERR'         
        do i=1,nstp
          do j=1,na
            write(sout,5) (i-(nstp+1)/2)*ar(j) 
          enddo
          write(sout,55) spcy(i),spcd(i)          
        enddo
        spcn=nstp
      return  
999   write(*,*)  'Cannot open file as unit ',i_io      
      return
      end
#
#***********************************************************************
      SUBROUTINE BENCH
# /// simulate flux at the sample (arg<>2) or at the detector (arg=2)
# /// by forward method (ICOM=1) or "from the sample" (ICOM=0)      
#***********************************************************************
#
      implicit none

      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      integer*4 nb  

      nb=1000
      imonit=-1
      if(nos.gt.0) nb=nint(1000*ret(1))
      call NESS_CONV(1)
      call NESS(2,0.d0)
      call NESS_BENCH(nb)
      
      return
      end                   
#
#
#***********************************************************************
      SUBROUTINE ROCK(icr)
# simulates rocking curve for monochromator (icr=1) or analyzer (icr=2)
# arguments: NEVENTS, NSTEPS, STEP [min]   
# saves results in rcurve.dat   
#***********************************************************************
#
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      integer*4 icr,nc,nth,i  
      real*8 rth(129),dth,divh,divv

      nc=1000
      nth=65
      dth=2./180./60.*pi
      divh=0.
      divv=0.
      if(nos.gt.0) nc=nint(1000*ret(1))
      if(nos.gt.1) nth=nint(ret(2))
      if(nth.lt.11) nth=11
      if(nth.gt.129) nth=129
      if(nos.gt.2) dth=ret(3)/180/60*pi
      if(nos.gt.3) divh=ret(4)/180/60*pi
      if(nos.gt.4) divv=ret(5)/180/60*pi
      call NESS_CONV(1)
      call SPEC_INI(0,3)
      if (nos.gt.0.and.ret(1).eq.0.) then
        call TEST_SYMMETRY(nc,nth,dth,divh,divv)      
      else
        call NESS_ROCK(icr,nc,nth,dth,rth,divh,divv)
        open(22,file= 'rcurve.dat',status= 'unknown',err=100)
1       format(a)
2       format(2(e11.5,4x))
        write(22,1)  'theta[min]   r(theta)'
        do i=1,nth
          write(22,2) (-(nth-1)/2.+i*1.)*dth*180*60/pi,rth(i)
        enddo      
100     close(22)
      endif  
      
      return
      end                   
#
#***********************************************************************
      SUBROUTINE TYPECFG
# /// print complete configuration of all components
#***********************************************************************
#
      implicit none

       INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      integer*4 n

      call NESS_CONV(1)
      if(nos.gt.0) then
         n=nint(ret(1))
         if (n.gt.9) then
           call SPEC_INI(0,8)            
         else
           call SPEC_INI(0,3)          
         endif
         if(n.eq.1) call SLIT_WRITE(sout,sou)
         if(n.eq.2) call BENDER_WRITE(sout,gdea)
         if(n.eq.3) call BENDER_WRITE(sout,guide)
         if(n.eq.4) call BENDER_WRITE(sout,sol1)
         if(n.eq.5) call CRYST_WRITE(sout,mon)
         if(n.eq.6) call BENDER_WRITE(sout,sol2a)
         if(n.eq.7) call BENDER_WRITE(sout,sol2)
         if(n.eq.8) call SLIT_WRITE(sout,sam)
         if(n.eq.9) call BENDER_WRITE(sout,sol3)
         if(n.eq.10) call CRYST_WRITE(sout,ana)
         if(n.eq.11) call BENDER_WRITE(sout,sol4)
         if(n.eq.12) call SLIT_WRITE(sout,det)
      else
          call SPEC_INI(0,8)
          call WRITE_SETUP(sout,8)
      endif
      
      return
      end                   

#-----------------------------------------------------------        
      SUBROUTINE SET_DEVICE(sarg)
# set graphics device string for PGPLOT
#-----------------------------------------------------------      
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) sarg
      character*60 dst
      integer*4 i,pgbegin
1     format( ' Graphics device (? for help) : ',$)
2     format(a)
#//      write(sout,*) DEVSTR

      write(sout,*) "present device: ",devstr
      if (sarg.ne. ' ') then
         devstr=sarg
         write(sout,*) "new device: ",devstr(1:i)         
      else 
         write(sout,1)
         read(sinp,2) dst
201      i=pgbegin(0,dst,1,1)
         if (i.ne.1) then
           write(smes,*) "pgbegin error: ",i
           dst= '?'
           goto 201
         end if
         call pgqinf( 'DEV/TYPE',devstr,i)
         write(smes,*) "new device: ",devstr(1:i)         
         call pgend  
         return
      endif
      end
      
#-----------------------------------------------------------        
      SUBROUTINE SETVAR(ivar)
#    
#-----------------------------------------------------------      
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'source.inc'
      integer*4 ivar

1     format( ' Source flux [1e14 n/s/cm^2] : ',f10.4)
2     format( ' Source temperature [K] : ',f6.0)
      if (ivar.eq.1) then         
         if(nos.ne.0) sflux=ret(1)
         write(sout,1) sflux
      endif   
      if (ivar.eq.2) then         
         if(nos.ne.0) stemp=ret(1)
         write(sout,2) stemp
      endif   
      return
      end


#-------------------------------------------------------------
      SUBROUTINE SETCFG(sarg)
# Read configuration file
# IF IREAD>0, prepare also all calculated fields and run TRAX!
#-------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) sarg
      character*128 name,fn,fres
      integer*4 is,il,ires,isc,ilc
      logical*4 isdefname,iscreated

1     format( ' Configuration file [*.cfg]: ',$)
11    format( ' Configuration file [',a, ']: ',$)
2     format(a)
3     format( 'Cannot find configuration file ',a,/,
     *        '=> trying default: ',a)
4     format( 'Cannot find configuration file ',a,/,
     *        '=> trying the previous one: ',a)
5     format( 'Could not open any configuration file !!')
6     format( 'Could not find default cfg. file ',
     &        '=> creating one in current directory')
          
      iscreated=.false.
# Get filename from dialog or from the argument SARG 
      call BOUNDS(sarg,is,il)
      call BOUNDS(cfgname,isc,ilc)
      if (il.eq.0) then
        if (ilc.le.0) then  ! both SARG and CFGNAME are empty
          write(smes,1)
          read(sinp,2) name
        else
          write(sout,11) cfgname(isc:isc+ilc-1)  ! offer current CFGNAME as default
          read(sinp,2) name 
          if (name.eq. ' ')  name=cfgname(isc:isc+ilc-1)
        endif  
      else
        name=sarg(is:is+il-1)
      endif

10    call BOUNDS(name,is,il)
      fn=name(is:is+il-1)
      isdefname=(fn(1:il).eq.rescal_defname)  ! is FN the default filename ?
      
# Add .cfg extension if NAME doesn't have one
      if (il.le.4.or.fn(il-3:il).ne. '.cfg') then 
        if (128.ge.il+4) then  ! append .cfg if there is enough space
          fn=name(is:is+il-1)// '.cfg' 
          il=il+4
        endif
      endif
      call CHECKRESFILE(fn,ires,fres,silent)
# file not found:
      if (ires.le.0) then
        if(isdefname) then   ! default not found => create one
           write(sout,6)
           call WRITEDEFCFG
           iscreated=.true.
           goto 10
        else if (ilc.gt.0) then   ! there is a previous filename => try it
           write(sout,4) fn(1:il),cfgname(isc:isc+ilc-1)
           name=cfgname(isc:isc+ilc-1)
           goto 10
        else if (.not.iscreated) then  ! try the default                  
           write(sout,3)  ' ',rescal_defname
           name=rescal_defname
           goto 10
        else   ! something is wrong - file was created but cannot read it !
           write(sout,5)  ! should not happen except the lack of write privileges or quota
           return           
        endif
      endif

# note: CFGNAME=FN is without path, FRES is complete pathname
      call BOUNDS(fres,is,il) 
      cfgname=fn
      
      call READCFG(fres(is:is+il-1))   ! read parameters from *.cfg
      end

#-----------------------------------------------------------------------
      SUBROUTINE SETPATH(sarg)
# select search path for data files      
#-----------------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      
      character*(*) sarg
      character*128 mypath
      integer*4 is,il
      
1     format( ' Path to data files [',a, '] : ',$)
2     format(a)       
3     format( ' Data in ',a)
       
      call BOUNDS(datpath,is,il)
# Get pathname from dialog or from the argument SARG 
      if (sarg.eq. ' ') then
        if (il.le.0) then
          write(sout,1)  'current folder'
          read(sinp,2) mypath
        else
          write(sout,1) datpath(is:is+il-1)
          read(sinp,2) mypath 
          if (mypath(1:1).eq. ' '.or.mypath(1:1).eq.char(0)) then
             mypath=datpath(is:is+il-1)
          endif
        endif  
      else
        mypath=sarg
      endif
# Interpret MYPATH, ensure that ending / is present       
      call BOUNDS(mypath,is,il)
      if ((il.le.0).or.
     *    (il.eq.1.and.mypath(is:is+il-1).eq. '.').or.
     *    (il.eq.2.and.mypath(is:is+il-1).eq. '.'//pathdel)) then
         datpath= ' '
         write(sout,3)  'current folder'
         return
      endif
      if(mypath(is+il-1:is+il-1).ne.pathdel) then
         datpath=mypath(is:is+il-1)//pathdel
      else   
         datpath=mypath(is:is+il-1)
      endif
      write(sout,3) datpath(1:il)
      end  
      
      
#-----------------------------------------------------------------------
      SUBROUTINE SETRESPATH(sarg)
# select search path for configuration files      
#-----------------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      
      character*(*) sarg
      character*128 mypath
      integer*4 is,il
      
1     format( ' Additional search path for configuration files [',
     *         a, '] : ',$)
2     format(a)       
3     format( ' Configurations in ',a)
       
      call BOUNDS(respath,is,il)
# Get pathname from dialog or from the argument SARG 
      if (sarg.eq. ' ') then
        if (il.le.0) then
          write(sout,1)  'current folder'
          read(sinp,2) mypath
        else
          write(sout,1) respath(is:is+il-1)
          read(sinp,2) mypath 
          if (mypath(1:1).eq. ' '.or.mypath(1:1).eq.char(0)) then
             mypath=respath(is:is+il-1)
          endif
        endif  
      else
        mypath=sarg
      endif
# Interpret MYPATH, ensure that ending / is present       
      call BOUNDS(mypath,is,il)
      if ((il.le.0).or.
     *    (il.eq.1.and.mypath(is:is+il-1).eq. '.').or.
     *    (il.eq.2.and.mypath(is:is+il-1).eq. '.'//pathdel)) then
         respath= ' '
         write(sout,3)  'current folder'
         return
      endif
      if(mypath(is+il-1:is+il-1).ne.pathdel) then
         respath=mypath(is:is+il-1)//pathdel
      else   
         respath=mypath(is:is+il-1)
      endif
      write(sout,3) respath(1:il)
      end  

#-----------------------------------------------------------------------
      SUBROUTINE LIST
#-----------------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      
      integer*4 i1,i
       
19     format( ' ',a5, ' = ',g14.7,1x,$)                     
51     format( ' ',2(a4, ' = ',f10.5,1x),/,                    ! DM,DA
     2         ' ',3(a4, ' = ',f10.2,1x),/,                    ! ETAM,ETAA,ETAS
     3         ' ',3(a4, ' = ',f10.0,1x),/,                    ! SM,SA,SS 
     4         ' ',a4, ' = ',f10.5,1x, a4, ' = ',f10.0,1x,/,   ! KFIX,FX 
     5         ' ',4(a4, ' = ',f10.2,1x),/,                    ! ALF1..4 
     6         ' ',4(a4, ' = ',f10.2,1x),/,                    ! BET1..4
     7        4( ' ',3(a4, ' = ',f10.4,1x)/),                  ! AS,AA,AX,BX     
     1         ' ',4(a4, ' = ',f10.4,1x),/,                    ! QH..EN
     2         ' ',4(a4, ' = ',f10.4,1x),/,                    ! DQH..DE
     2         ' ',2(a4, ' = ',f10.4,1x),/,                    ! DA3,DA4
     3         ' ',4(a4, ' = ',f10.4,1x),/,                    ! GH..GL,GMOD
     4         ' ',4(a4, ' = ',f10.4,1x),/,                    ! ROMH..ROAV
     5         ' ',2(a4, ' = ',f10.2,1x))                      ! SDI,SHI

       if (nos.ge.1)   then  
         do i=1,nos    
           i1=nint(ret(i))
           if (i1.gt.0.and.i1.lt.res_nvar) then
              write(sout,19) res_nam(i1),res_dat(i1)
           endif
         enddo
         write(sout,*)
       else
         write(sout,51) (res_nam(i),res_dat(i),i=1,res_nvar)   
#         nos=0
#         call SET_3AX(1)
#         call SET_3AX(3)
#         call SET_3AX(4)
#         call SET_3AX(5)
#         call SET_3AX(6)
       endif
       end
       
#--------------------------------
      SUBROUTINE DOSHELL(comm)
# execute shell command      
#--------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) comm
      character*256 comm1
      integer*4 is,l
      
1     format( ' Command : ',$)
2     format(a)
      comm1= ' '
      if((comm(1:1).eq. ' ').or.(comm(2:2).eq.char(0))) then 
        write(sout,1)
        read(sinp,2) comm1
      else
        l=len(comm)
        if(l.gt.256) l=256
        comm1=comm(1:l)
      endif
      call BOUNDS(comm1,is,l)
      
      if (l.gt.0) then
        call system(comm1(is:is+l-1))
      endif
      end
      
#**********************************************************************
      SUBROUTINE REINP(sarg)
#     redirection of input
#***********************************************************************
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) sarg
      integer*4 iuini,iufile,ires
      data iuini,iufile/0,10/
      
      if(iuini.eq.0) iuini=sinp      
      if (sinp.ne.iuini) close(sinp)
      if((sarg(1:1).ne. ' ').and.(sarg(1:1).ne.char(0))) then
          call OPENRESFILE(sarg,iufile,ires,0) 
          if (ires.le.0) goto 2002        
          sinp=iufile
      else
          sinp=iuini
      endif   
      return     

2002  write(smes,*)  'Cannot open input file '//sarg
      sinp=iuini
      end 

#**********************************************************************
      SUBROUTINE REOUT(sarg)
#     redirection of input
#***********************************************************************
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*(*) sarg
      integer*4 iuini,iufile
      data iuini,iufile/0,11/
      
      if(iuini.eq.0) iuini=sout      
      if (sout.ne.iuini) close(sout)
      if((sarg(1:1).ne. ' ').and.(sarg(1:1).ne.char(0))) then
          open (unit=iufile,err=2002,name=sarg, status= 'UNKNOWN')          
          sout=iufile
      else
          sout=iuini
      endif   
#      WRITE(*,*) SOUT
      return     

2002  write(smes,*)  'Cannot open output file  '//sarg
      sout=iuini
      end 

#-----------------------------------------------------
      SUBROUTINE READINIFILE(jobname)
#   read initialization file
# CFGNAME = configuration file  
# DATAPATH = path to the data files   
# OPENFILE = data or RESCAL file to open   
# return JOBNAME .. filename of a job file to be executed at the startup 
#-----------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      character*128 line
      character*(*) jobname
      integer*4 ires,ierr
      
1     format(a)
      jobname= ' '
      call OPENRESFILE( 'restrax.ini',22,ires,0)
      if(ires.gt.0) then
         ires=0
         do while(ires.eq.0)
           read(22,1,end=100,iostat=ires) line
           if(line(1:1).ne. '#') then 
             call READ_STR( 'CFGNAME',line,cfgname,ierr)
             call READ_STR( 'DATAPATH',line,datpath,ierr)
             call READ_STR( 'JOB',line,jobname,ierr)
             call READ_STR( 'OPENFILE',line,rescal_name,ierr)
           endif  
         enddo
100      close(22)      
      endif
      end
       

#----------------------------------------------------------------------------- 
      SUBROUTINE PROCARG
#// Process command line arguments for SIMRES
#----------------------------------------------------------------------------- 
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'randvars.inc'
      INCLUDE 'source.inc'
      integer*4 i,j,m,is,il
      character*128 s
      integer*4 iargc
      
# Handle command-line options
      m=iargc()
      
# Derive path to default setup files from executable pathname
      
      call getarg(0,s)
      i=index(s,pathdel// 'bin'//pathdel)       
      if (i.gt.1) then
         cfgpath=s(1:i)// 'setup'//pathdel
      else
         cfgpath= 'setup'//pathdel
      endif
        
      idbg=0
      irnd=0
      iopt=1   ! automatic optimization by default
      normmon=0  ! constant monitor efficiency (NOT ~ 1/k)
      mdist=0
      m=iargc()
      do i=1,m
        call getarg(i,s)
        if (s(1:5).eq. '-dir=') then
           call BOUNDS(s,is,il)
           is=is+5
           il=il-5
           if(il.gt.0) then
             respath=s(is:is+il-1)
             if(respath(1:il).ne.pathdel) then  ! add path delimiter
                respath=respath(1:il)//pathdel
                il=il+1
             endif
             write(sout,*)  'dir='//respath(1:il)
           endif  
        else if (s(1:2).eq. '-d') then
           idbg=2
           read(s(3:3),*,err=10) j
           if(j.ne.0) idbg=j
        endif   
10      if (s(1:2).eq. '-s') then
           read(s(3:30),*) j
           if(j.ne.0) then 
               iseed=abs(j) 
               write(sout,*)  'SEED=',iseed
           endif
        endif
        if (s(1:2).eq. '-t') then
           read(s(3:30),*,err=20) j
           call RAN1SEED(iseed)
           write(*,*)  'Test of the random number generator:'
           call RAN1TEST(j,1000000*j)
20         goend=1
           return
        endif
        if (s(1:4).eq. '-flx') then
          call READ_FLUX(s(5:))
        endif
        if (s(1:4).eq. '-flh') then
           read(s(5:30),*,err=30) flxh
           flxh=flxh*pi/180
        endif
30      if (s(1:4).eq. '-flv') then
           read(s(5:30),*,err=35) flxv
           flxv=flxv*pi/180
        endif
35      if (s(1:3).eq. '-RB') then
           read(s(4:30),*,err=40) cbar
           write(*,*)  'Right barrier [mm]: ',cbar
        endif
40     if (s(1:3).eq. '-MX') then
           read(s(4:30),*,err=50) cmx
           write(*,*)  'crystal shift x [mm]: ',cmx
        endif
50      if (s(1:6).eq. '-Voigt') then
           mdist=1
           write(*,*)  'pseudo-Voigt mosaic distribution'
        else if (s(1:7).eq. '-Lorenz') then
           mdist=2
           write(*,*)  'Lorenzian mosaic distribution'
        else if (s(1:4).eq. '-Uni') then
           mdist=3
           write(*,*)  'Uniform mosaic distribution'
        else 
           mdist=0
           write(*,*)  'Gaussian mosaic distribution'
        endif
        if (s(1:4).eq. '-sil') then
           read(s(5:30),*,err=60) silent 
           write(sout,*)  'SILENT=',silent 
        endif
60      if (s(1:5).eq. '-ran1') then
           irnd=1
           write(*,*)  'Numerical Recipes RAN1 generator'
        endif
        if (s(1:5).eq. '-rand') then
           irnd=2
           write(*,*)  'System random number generator'
        endif
        if (s(1:6).eq. '-noopt') then
           iopt=0
           write(*,*)  'No automatic sampling optimization'
        endif
        if (s(1:5).eq. '-nmon') then
           normmon=1
           write(*,*)  'Incident intensities ~ 1/ki'
        endif
        if (s(1:6).eq. '-cross') then
           isqom=0
           read(s(7:7),*,err=70) j
           if(j.gt.0.and.j.le.3) isqom=j
           if (isqom.eq.1) then
             write(*,*)  'SCAN with antif. magnon cross-section'
           else if (isqom.eq.2) then
             write(*,*)  'SCAN with Vanadium sample'
           endif  
        endif   
70      if (s(1:4).eq. '-log') then
           logfile=s(5:30)
           write(*,*)  'Events logged in '//logfile
100        format( 'Log events between [min max]: ',$)
           write(*,100)
           read(*,*) logmin,logmax
        endif
        if (s(1:5).eq. '-help'.or.s(1:1).eq. '?') then
           do j=1,18
              write(*,*) hlpopt(j)
           enddo
           goend=1            
        endif
        enddo   
      end
      
#----------------------------------------------------------------------------- 
        SUBROUTINE RESINIT
#// initialize RESTRAX
#// include all actions necessary to allocate memory, 
#// initialize variables, print LOGO etc..                
#----------------------------------------------------------------------------- 
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'config.inc'
      INCLUDE 'randvars.inc'
      INCLUDE 'rescal.inc'

      integer*4 ires
      character*128 extname,outname,fname,jobname
      real*8 HMOS_DIST
      integer*4 i,READ_MIRROR
      external HMOS_DIST
      
20    format( 'Using default RESCAL parameters: ',a)
      
# initialize error function
      call ERF_INIT(HMOS_DIST,-6.d+0,6.d+0)
# clear mirror and flux lookup tables
      i=READ_MIRROR(-1.d0)
      call READ_FLUX( ' ')
      
# set path delimiter for M$ Windows
      call MKUPCASE(sysname)
      if (sysname(1:7).eq. 'WINDOWS') then
        pathdel= '\'
      endif
      
# default silence level:
      silent=1
      
# initialize LINP
      call LINPSET(res_nvar+res_ncmd, 'SimRes',res_nam,res_hlp)
      call LINPSETIO(sinp,sout,smes)

      goend=0      
# Handle command-line options
      call PROCARG 
      if (goend.ne.0) call RESEND
      
      call RAN1SEED(iseed)        ! Initialize random number generator
      call LOGO                   ! print LOGO
      call READINIFILE(jobname)  ! read restrax.ini file
      call SETRESPATH(respath)    ! set default path for configuration
      call UNITS(cunit)           ! set units for energy (meV)
      call SETPATH(datpath)       ! set data path to current dir.
      call SET_CRYST( 'Ge 111  ', 'Ge 111  ' ! read some crystal parameters
      call getenv( 'PGPLOT_DEV',fname)
      if(fname(1:1).ne. ' ') then
         devstr=fname
      endif
      call OPENFILE(rescal_name,ires)
      if (ires.le.0) then      
         call SETDEFRES
         write(smes,20) rescal_defname
      endif   
      call SETCFG(cfgname)        ! Read the configuration file
# job file required by restrax.ini      
      
      if (jobname(1:1).ne. ' ') then 
         call REINP(jobname)
         call LINPSETIO(sinp,sout,smes)
         return  
      endif

# ask for a job file
2000  format(a30)
2001  format( ' batch file  : ',$)
2004  format( ' output file : ',$) 
      write(*,2001)   
      read(*,2000) extname
      if((extname(1:1).ne. ' ').and.(extname(1:1).ne.char(0))) then
        call CHECKRESFILE(extname,ires,fname,silent)
        if (ires.gt.0) then
           write(*,2004)
           read(*,2000) outname
           if((outname(1:1).ne. ' ').and.(outname(1:1).ne.char(0))) then             
              call REOUT(outname)
              write(sout,*)  'RESTRAX - batch job '//extname
           endif
           call REINP(fname)    
           call LINPSETIO(sinp,sout,smes)
#           write(*,*) 'input/output is ',SINP,'/',SOUT
        endif
      endif
           
      end

#-----------------------------------------------------------------------------   
        SUBROUTINE RESEND
#// end of RESTRAX
#// include all actions necessary to deallocate memory etc...                
#-----------------------------------------------------------------------------  
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      
      call REINP( ' ')
      call REOUT( ' ')
      call NESSEND    !  NESSEND must be called to deallocate
      write(smes,*)  ' -> End of ResTrax'
      stop 
      end