src/simres_cmd.f

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

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


#***************************************************************
      SUBROUTINE RESTRAX_HANDLE(scomm)
#  A wrapper to CMD_HANDLE for DLL export  
#***************************************************************
      implicit none      
      INCLUDE 'linp.inc'
      character*(*) scomm
2     format(a,$)

      integer*4 l      
      l=len(scomm)      
      call CMD_HANDLE(scomm(1:l))
      write(linp_out,2) linp_p(1:linp_np)// '> ' 

      
      end

#***************************************************************
      SUBROUTINE CMD_HANDLE(scomm)
#  Main command handler for RESTRAX  
#  call CMD_HANDLE(' ') as the first command of RESTRAX and then 
#  any time you need to reset default menu
#***************************************************************
      implicit none      
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'linp.inc'
#      INCLUDE 'restrax.inc'
      
      character*(*) scomm
      integer*4 icom,npar,l,i,ires,ierr
      character*128 line,LINPEXECSTR
      logical*4 CHECKPARAM
      integer*4 initialized,TRUELEN
      data initialized /0/  
      data  needbefore/.true./   

2     format(a5, ' = ',g12.6)
            
100   format(1x,70( '-'))
200   format(1x, 'RESTRAX Error: ',i4,/,1x,a)

      l=TRUELEN(scomm)
# first call => initialize RESTRAX
      if (initialized.eq.0) then        
        call RESINIT 
        initialized=1
      endif  

# ignore comments and empty lines
      if (l.le.0.or.scomm(1:1).eq. '#') return  
      
# send commands to linp
      if (scomm(1:l).eq. 'SETLINP') then
        call LINPSET(res_nvar+res_ncmd, 'SimRes',res_nam,res_hlp)
        call LINPSETIO(sinp,sout,smes)
        return
      endif

      res_nmsg=0
      retstr= ' '
      line= ' '      
      
#// process command string through LINP
      line=LINPEXECSTR(scomm(1:l),icom,npar)
      if (icom.lt.0) return   ! command not recognised

#// get numeric arguments       
      call GETLINPARG(line,ret,40,nos) 

#// get the whole line as a string argument      
      if (npar.gt.0) retstr=line

#// process input parameters
      if (icom.gt.0.and.icom.le.res_nvar) then          
          if (nos.gt.res_nvar-icom+1) nos=res_nvar-icom+1  
          if (nos.gt.0) then
            do i=1,nos
               res_dat(icom+i-1)=ret(i)
               ret(i)=icom+i-1
            enddo
            call LIST
            nos=0
            needbefore=.true.
          else
            write(sout,2) res_nam(icom),res_dat(icom) 
          endif
          return 
      endif           
           
#// do initialization if needed
      if (needbefore) then
          call BEFORE(ierr)
          needbefore=(ierr.ne.0)
          if (needbefore) return
      endif  
   
#// process I/O commands
      if (line(1:4).eq. 'LIST') then
          call LIST
      else if (res_nam(icom).eq. 'SAVE') then
          call WRITE_RESCAL(retstr,ires)
      else if (res_nam(icom).eq. 'PATH') then
          call SETPATH(retstr)
      else if (res_nam(icom).eq. 'FILE') then
          call OPENFILE(retstr,ires)
          needbefore=(ires.gt.0)
      else if (res_nam(icom).eq. 'BAT') then
          call REINP(retstr)    
          call LINPSETIO(sinp,sout,smes)
      else if (res_nam(icom).eq. 'CFG') then
          call SETCFG(retstr)        
      else if (res_nam(icom).eq. 'CRYST') then
          call SET_3AX(8)
          needbefore=.true.
      else if (res_nam(icom).eq. 'GRFDE') then
          call SET_DEVICE(retstr) 
      else if (res_nam(icom).eq. 'PLOT') then
          call PLOTOUT(0)
      else if (res_nam(icom).eq. 'PRINT') then
          call PRINTOUT
      else if (res_nam(icom).eq. 'SETUP') then
          call TYPECFG
      else if (res_nam(icom).eq. 'SVOL') then
          call PLOTOUT(1)
      else if (res_nam(icom).eq. 'LPROF') then
          call PLOTOUT(2)         
      else if (res_nam(icom).eq. 'DPROF') then
          call PLOTOUT(3)
      else if (res_nam(icom).eq. 'TPROF') then
          call PLOTOUT(4)     
      else if (res_nam(icom).eq. 'MPROF') then
            call PLOTOUT(5)    
      else if (res_nam(icom).eq. 'SHELL') then
          call DOSHELL(retstr)
      else if (line(1:4).eq. 'LIST') then
          call LIST
      else if (res_nam(icom).eq. 'EXIT'.
     *           or.line(1:4).eq. 'QUIT') then
             goend=1           
      else if (res_nam(icom).eq. 'EXFF') then
             goend=1           
#// process execution commands
      else if (icom.gt.res_nvar) then    !  other commands are treated outside
        if (CHECKPARAM()) then
           call CMD_PROCESS(icom)
        endif
        write(sout,100)
        if (res_nmsg.ne.0) write(smes,200) res_nmsg,res_msg
      endif 
      
      if (goend.ne.0) then
         initialized=0
         call RESEND
      endif   

      end      

#***************************************************************
      SUBROUTINE CMD_PROCESS(icmd)
#  Process RESTRAX  execution commands
#***************************************************************
      implicit none      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      integer*4 icmd
#      LOGICAL*4 CMDFILTER
      
#        write(*,*) 'Process ',ICMD
#      IF (.NOT.CMDFILTER(ICMD)) RETURN  ! filter for commands       
#      CALL MAKEMC(RES_NAM(ICMD))        ! call Monte Carlo if necessary (call IFNESS)
                          

      if (res_nam(icmd).eq. 'RO')  call GETRO(sout-1)
      if (res_nam(icmd).eq. 'MRO') call GETROOPTMC(sout-1)
      if (res_nam(icmd).eq. 'MONO') call SET_3AX(2)
      if (res_nam(icmd).eq. 'ANAL') call SET_3AX(21)
      if (res_nam(icmd).eq. 'THETA') call SET_3AX(3) 
      if (res_nam(icmd).eq. 'POLAR') call SET_3AX(7)
      if (res_nam(icmd).eq. 'FLIP') call SET_3AX(4) 
      if (res_nam(icmd).eq. 'MAG')  call SET_3AX(5) 
      if (res_nam(icmd).eq. 'SPIN') call SET_3AX(6) 
      if (res_nam(icmd).eq. 'FLX')  call SETVAR(1)
      if (res_nam(icmd).eq. 'TEMP') call SETVAR(2)
      if (res_nam(icmd).eq. 'SRCX') call SET_3AX(10)    
      if (res_nam(icmd).eq. 'SRCY') call SET_3AX(11)    
      if (res_nam(icmd).eq. 'OSC')  call SET_3AX(9)   
      if (res_nam(icmd).eq. 'SPOS')  call SET_3AX(1)
      if (res_nam(icmd).eq. 'EMOD')  call SET_3AX(13)
      if (res_nam(icmd).eq. 'AMOD')  call SET_3AX(12)
      if (res_nam(icmd).eq. 'FLUX')  call SAM_FLUX(1)
      if (res_nam(icmd).eq. 'NFLUX') call SAM_FLUX(0) 
      if (res_nam(icmd).eq. 'MONIT') call SAM_FLUX(2)
      if (res_nam(icmd).eq. 'ROCK')  call ROCK(1)
      if (res_nam(icmd).eq. 'AROCK') call ROCK(2)
      if (res_nam(icmd).eq. 'PWD')  call SAM_FLUX(4)
      if (res_nam(icmd).eq. 'PWDS') call SAM_FLUX(5)
      if (res_nam(icmd).eq. 'TAS')  call SAM_FLUX(3)
      if (res_nam(icmd).eq. 'BENCH') call BENCH
      if (res_nam(icmd).eq. 'SCHI') call SCAN_CHI(0)
      if (res_nam(icmd).eq. 'SCAN') call SCAN_THETA
      
# Setup might have changed => update TRAX and compare with previous configuration  
      if ((res_nam(icmd).eq. 'RO').or.
     &     (res_nam(icmd).eq. 'MRO').or.
     &     (res_nam(icmd).eq. 'OPTAS'))  needbefore=.true. 
      end