src/restrax_cmd.f

Fortran project RESTRAX, source module src/restrax_cmd.f.

Source module last modified on Mon, 29 May 2006, 12:27;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#***************************************************************
# $Id: restrax_cmd.f,v 1.11 2006/05/29 10:27:03 saroun Exp $
#
# IMENU ... actually active menu set in LINP
# LMENU ... submenu level (LMENU=1 for the main manu)
# CMENU(LMENU) ... actually selected submenu on the level LMENU
# comment:
#----------
# IMENU changes only if LINP_SET is called with new menu items
# CMENU is set when menu handler is called with empty argument (to stay there)
# or on QUIT (return to parent menu)  
#***************************************************************

#***************************************************************
      SUBROUTINE RESTRAX_HANDLE(scomm)
#  A wrapper to CMD_HANDLE for DLL export  
#***************************************************************
      implicit none      
      INCLUDE 'linp.inc'
      INCLUDE 'restrax_cmd.inc'
      character*(*) scomm
      integer*4 l   
         
2     format(a,$)
      cmdmode=0  ! no command-line interaction
      l=len(scomm)      
      call CMD_HANDLE(scomm(1:l))
      write(linp_out,2) linp_p(1:linp_np)// '> ' 
      end

#***************************************************************
      SUBROUTINE CMD_INIT
#  Initializes command interpreter
#  Sets appropriate prompt and menu contents according to CMENU(LMENU) value
#***************************************************************
      implicit none      
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'linp.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'
      
      character*10 prompt
      integer*4 iq
      
3     format( 'ResTrax_',i1)
4     format( 'ResTrax_',i2)

#// initialize menu if it has changed
      if (imenu.ne.cmenu(lmenu).or.lmenu.lt.1) then      
# main menu
        if (lmenu.le.1.and.imenu.ne.mn_main) then  ! first entry => set LINP with menu items
          if(mf_max.le.1) then  ! set prompt according to the focused data set
            prompt= 'ResTrax'
          else
            if(mf_cur.lt.10) write(prompt,3) mf_cur
            if(mf_cur.ge.10) write(prompt,4) mf_cur
          endif    
          lmenu=1     
          imenu=mn_main
          cmenu(lmenu)=imenu
          call LINPSET(res_nvar+res_ncmd,prompt,res_nam,res_hlp)
          call LINPSETIO(sinp,sout,smes)
# submenu => initialize by a call with empty string
        else if (lmenu.gt.1.and.imenu.ne.cmenu(lmenu)) then
          select case (cmenu(lmenu))      
            case (mn_data)          
              call DATA_CMD( ' ',iq)
            case (mn_fit)
              call FIT_CMD( ' ',iq)
            case (mn_plot)
              call PLOT_CMD( ' ',iq)
          end select      
        endif
      endif
      end

#***************************************************************
      SUBROUTINE CMD_HANDLE(scomm)
# Main menu handler for RESTRAX  
# All user entry should be dispatched here
#***************************************************************
      implicit none      
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'linp.inc'
      INCLUDE 'res_grf.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'
      
      character*(*) scomm
      integer*4 iq,icom,npar,lcom,i,ierr
      character*128 line,LINPEXECSTR
      logical*4 nosave
      data  nosave/.false./   

1     format(a)
2     format(a5, ' = ',g12.6)
5     format(a,$)
#6     FORMAT('ITEM=',I2,' MENU=',I2,' LEVEL=',I2)           
100   format(1x,70( '-'))
200   format(1x, 'RESTRAX Error: ',i4,/,1x,a)

#// initialize fields
      lcom=len_trim(scomm)
      retstr= ' '
      line= ' '      
      res_nmsg=0
      
#      write(*,6) IMENU,CMENU(LMENU),LMENU

#// call the focused submenu, if any
      iq=0
      if (imenu.gt.0.and.lmenu.gt.1) then
        select case (cmenu(lmenu))      
          case (mn_data)          
            call DATA_CMD(scomm,iq)
          case (mn_fit)
            call FIT_CMD(scomm,iq)
          case (mn_plot)
            call PLOT_CMD(scomm,iq)
        end select
      endif
      
#// empty string or return from submenu => only set LINP and exit     
      if (iq.eq.1.or.lcom.eq.0.or.lmenu.gt.1) goto 99 
      
#// process command string through LINP
      line=LINPEXECSTR(scomm(1:lcom),icom,npar)
      if (icom.lt.0) return   ! command not recognised

#// get the whole line as a string argument      
      if (npar.gt.0) retstr=line
#// get numeric arguments       
      call GETLINPARG(line,ret(1),40,nos) 

#// standard commands (ICOM=0)
      if(icom.eq.0) then
          if (line(1:4).eq. 'LIST') then
             call LIST
          else if (line(1:4).eq. 'QUIT') then
             goend=1
          endif
#// process input parameters
      else 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)
            enddo
            nosave=.true.
            needbefore=.true.
          else
            write(sout,2) res_nam(icom),res_dat(icom) 
          endif    
#// process commands
      else if (icom.gt.res_nvar.and.icom.le.res_nvar+res_ncmd) then          
# do preliminary tasks (matrix update, call TRAX etc.) when needed
        if (needbefore) call BEFORE
      
# input-output commands
        if (res_nam(icom).eq. 'LSCFG') then
          call LISTCFG
        else if (res_nam(icom).eq. 'SAVE') then
          call WRITE_RESCAL(retstr,ierr)
          nosave=(ierr.ne.1)
        else if (res_nam(icom).eq. 'WRITE') then
          call WriteHist(retstr)
        else if (res_nam(icom).eq. 'PATH') then
          call SETPATH(retstr)
        else if (res_nam(icom).eq. 'CPATH') then
          call SETRESPATH(retstr)
        else if (res_nam(icom).eq. 'FILE') then
          call ADDDATA(retstr,npar,1,0)
        else if (res_nam(icom).eq. 'GRFDE') then
          call SELGRFDEV(retstr,0)
        else if (res_nam(icom).eq. 'BAT') then
          call REINP(retstr)
          call LINPSETIO(sinp,sout,smes)
        else if (res_nam(icom).eq. 'OUT') then
          call REOUT(retstr)        
          call LINPSETIO(sinp,sout,smes)
        else if (res_nam(icom).eq. 'CFG') then
          call SETCFG(retstr,1)        
        else if (res_nam(icom).eq. 'EXCI') then
          call SETEXCI(retstr,1)        
        else if (res_nam(icom).eq. 'OMEXC') then
          call REPORTOMEXC
        else if (res_nam(icom).eq. 'EXPR') then
          call EXPORT_RES(retstr)        
        else if (res_nam(icom).eq. 'IMPR') then
          call IMPORT_RES(retstr)        
        else if (res_nam(icom).eq. 'SHELL') then
          call DOSHELL(line)
        else if (line(1:4).eq. 'LIST') then
          call LIST
        else if (res_nam(icom).eq. 'EXIT') then
             goend=1           
        else if (res_nam(icom).eq. 'EXFF') then
             nosave=.false.  ! no warning on unsaved data before exit
             goend=1           
# sumbmenu calls
        else if (res_nam(icom).eq. 'FIT') then
           swraytr=0  ! ray-tracing=off
           call FIT_CMD(retstr,iq)        
        else if (res_nam(icom).eq. 'MFIT') then
           call MAKEMC(res_nam(icom))    ! call Monte Carlo if necessary (call IFNESS)
           call FIT_CMD(retstr,iq) 
        else if (res_nam(icom).eq. 'DATA') then
           call DATA_CMD(retstr,iq) 
        else if (res_nam(icom).eq. 'PLOT') then
           call PLOT_CMD(retstr,iq)       
        else if (res_nam(icom).eq. 'PRINT') then
           if (nos.ge.1.and.ret(1).eq.0) then
             call PRINTOUT  ! print text report
           else
             toprint=1      ! print the last plotted graphics
             call PLOTOUT
           endif

# execution commands:
# pass commands through CMD_PROCESS if
# a) want to apply CMDFILTER, or
# b) call ray-tracing when needed (MAKEMC), or
        else      !  other commands are treated outside
           call CMD_PROCESS(icom)
           write(sout,100)
        endif
      endif 
          
# report messages          
      if (res_nmsg.ne.0) write(smes,200) res_nmsg,res_msg

#// check for unsaved parmeters before termination     
      if (goend.ne.0) then
         if(nosave) then
            write(smes,*)  'Changed parameters are not saved !'
            write(smes,*)  'Repeat EXIT or QUIT to confirm.'
            nosave=.false.
            goend=0
         endif
      endif   
       
#// return from a submenu
99    if (iq.eq.1) then
          cmenu(lmenu)=0
          lmenu=lmenu-1
      endif

      call CMD_INIT  ! call INIT to reset menu items for actual level
      
      end      

#***************************************************************
      SUBROUTINE CMD_PROCESS(icmd)
#  Process RESTRAX  execution commands
# ICMD   ... command ID
#***************************************************************
      implicit none      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'res_grf.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.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. 'BRAG')  call BRAG(0)
        if (res_nam(icmd).eq. 'RES')   call RESOL(1,nint(ret(1)))
        if (res_nam(icmd).eq. 'MRES')  call RESOL(2,nint(ret(1)))
        if (res_nam(icmd).eq. 'SIMFC') call FCONE_INI
        if (res_nam(icmd).eq. 'RO')    call GETRO(1)
        if (res_nam(icmd).eq. 'ROA')   call GETRO(0)
        if (res_nam(icmd).eq. 'SPOS')  call SET_3AX(1)
        if (res_nam(icmd).eq. 'PHON')  call MCPHON
        if (res_nam(icmd).eq. 'MPHON') call MCPHON
        if (res_nam(icmd).eq. 'GENDT') call GENDT
        if (res_nam(icmd).eq. 'PROF')  then
                                           ! obsolete, disabled
                                      endif                                        
        if (res_nam(icmd).eq. 'EMOD')  call EMODE
        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. 'TAUF')  call SET_3AX(8)                 
        if (res_nam(icmd).eq. 'FWHM')  call FWHM(1)
        if (res_nam(icmd).eq. 'MFWHM') call FWHM(2)
        if (res_nam(icmd).eq. 'AMOD')  call FCONE_INI
        if (res_nam(icmd).eq. 'MBRAG') call BRAG(1) 
        if (res_nam(icmd).eq. 'OPTAS') call OPTINSTR
# Setup might have changed 
# => call BEFORE which updates TRAX parameters and compares with previous configuration  
      if ((res_nam(icmd).eq. 'RO').or.
     &     (res_nam(icmd).eq. 'ROA').or.
     &     (res_nam(icmd).eq. 'SPOS').or.
     &     (res_nam(icmd).eq. 'EMOD').or.
     &     (res_nam(icmd).eq. 'MAG').or.
     &     (res_nam(icmd).eq. 'TAUF').or.
     &     (res_nam(icmd).eq. 'AMOD').or.
     &     (res_nam(icmd).eq. 'OPTAS'))  needbefore=.true. 
      end

#--------------------------------------------------------------
      SUBROUTINE FIT_CMD_INIT(rm,fitcom,fithint,nlist)
#
#  Command handler for modifying model parameters, fitting control etc.
# IQ=1 inidicates return to the parent menu (=QUIT) 
#---------------------------------------------------------------
      implicit none      
      INCLUDE 'const.inc'
      INCLUDE 'exciimp.inc'
      INCLUDE 'restrax.inc'
      
      integer*4 i,nlist
      record /MODEL/ rm
      character*4 ch
      character*5 CONCAT
      character*5 fitcom(mpar+6)
      character*60 fithint(mpar+5)
2     format(i4)

        do i=1,rm.nterm     ! items 1..NTERM are reserved for model parameters
          fitcom(i)= ' '
          write(ch,2) i
          fitcom(i)=CONCAT( 'a',ch)
          fithint(i)=rm.parname(i)
        enddo
        fitcom(rm.nterm+1)= 'PLOT'
        fitcom(rm.nterm+2)= 'MAPSQ'
        fitcom(rm.nterm+3)= 'OMEXC'
        fitcom(rm.nterm+4)= 'INIT'
        fitcom(rm.nterm+5)= 'FIX'
        fitcom(rm.nterm+6)= 'RUN'
        fithint(rm.nterm+1)= 'plot data & fit'
        fithint(rm.nterm+2)= 'plot map of S(Q) at E=const.'
        fithint(rm.nterm+3)= '[qh qk ql] get omega for given qhkl'
        fithint(rm.nterm+4)= 'initialization of the scattering model'
        fithint(rm.nterm+5)= '[n1 n2 ..] fix/free listed parameters'
        fithint(rm.nterm+6)= '[it] start fitting, max. it steps' 
        nlist=rm.nterm+6
#        write(*,*) 'FIT_CMD',SWRAYTR
        if (swraytr.gt.0) then
          call LINPSET(nlist, 'MFIT',fitcom,fithint)
        else
          call LINPSET(nlist, 'FIT',fitcom,fithint)
        endif
        
      end
#--------------------------------------------------------------
      SUBROUTINE FIT_CMD(scomm,iq)
#
#  Command handler for modifying model parameters, fitting control etc.
# IQ=1 inidicates return to the parent menu (=QUIT) 
#---------------------------------------------------------------
      implicit none      
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'res_grf.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'      
      INCLUDE 'linp.inc'
      INCLUDE 'exciimp.inc'
            
      record /MODEL/ rm
      real*8 chkqom
      
      character*(*) scomm
      integer*4 iq,icom,npar,nlist,itmax,i,j,ifx,is,il,lcom
      character*128 line,LINPEXECSTR
      character*5 fitcom(mpar+6)
      character*60 fithint(mpar+5),sline
#      REAL*8 OLDCHKQOM,GETSQOM
      real*8 dum6(6),dum61(6)
      logical*4 lback  ! indicates return from a submenu (PLOT calls ...)
      save fitcom,fithint
      data lback/.false./

4     format(a, '=',g12.5)
#6     FORMAT('FIT_CMD ITEM=',I2,' MENU=',I2,' LEVEL=',I2)           

      call getmodel(rm) 
      call getqomegainf(i,chkqom) 
           
      lcom=len_trim(scomm)
      iq=0
#// initialization
      if (imenu.ne.mn_fit) then  ! first entry => set LINP with menu items
#      write(*,6) IMENU,CMENU(LMENU),LMENU
        imenu=mn_fit
        if (lcom.eq.0) then  ! empty argument => stay in the menu
          if (.not.lback) lmenu=lmenu+1
          cmenu(lmenu)=imenu
#      write(*,6) IMENU,CMENU(LMENU),LMENU
        endif
        if (.not.lback) then  ! initialize EXCI except of return form a subcommand
          call HISTINIT             ! default histogram partitioning
          jfit=0                    ! monitor fitting status (no fit)
        endif
        lback=.false.
        call FIT_CMD_INIT(rm,fitcom,fithint,nlist)        
        if (lcom.le.0) call LISTFITPAR           ! list parameters at the begining        
      endif
      
      
      if (lcom.eq.0) return  ! ignore empty commands
     
#// process command through LINP      
      line=LINPEXECSTR(scomm(1:lcom),icom,npar)      
      if (icom.lt.0) return   ! command not recognised

#        write(*,*) 'FIT_CMD: <'//SCOMM(1:LCOM)//'>',ICOM,NLIST
      
#// get numeric arguments       
      call GETLINPARG(line,ret(1),40,nos) 
                   
#// standard commands (ICOM=0)
      if(icom.eq.0) then
# LIST
         if (line(1:4).eq. 'LIST') then
            call LISTFITPAR 
# QUIT
         else if (line(1:4).eq. 'QUIT') then
            if (iand(whathis,1).eq.0) call RESFIT(0)  ! update histogram  
            if (cfgmode.ne.1.and.iand(whathis,1).eq.1) then  ! replot result if mode <> flat-cone 
              call PLOT_CMD( 'SCAN',iq)
            endif
            call WriteHist( ' ' ! write results in a file 
            iq=1  ! return flag
        endif 
# parameters
      else if (icom.gt.0.and.icom.le.rm.nterm) then

#        write(*,*) '<'//FITCOM(ICOM)//'>',ICOM,rm.NTERM
          if (nos.gt.0) then
             i=icom 
             do while (i.le.rm.nterm.and.i-icom+1.le.nos)
               fpar(i)=ret(i-icom+1)
               rm.param(i)=fpar(i)  ! share with EXCI
               i=i+1
             enddo  
             call setmodel(rm)  ! update exci data
             
# call EXCI(-1): this is a trick how to apply changes
# so that EXCI can update internal fields from param(i), 
# otherwise, old values would go back to param(i) when calling EXCI(0) 
             call EXCI(-1,mf_par(i_qh,mf_cur),dum6,dum61) 
             
             call LISTFITPAR
          else
             call BOUNDS(rm.parname(icom),is,il)
             write(sline,4) rm.parname(icom)(is:is+il-1),rm.param(icom)
             call WRITELINE(sline,sout)
          endif
# identified commands (ICOM>NTERM)
      else if (icom.gt.rm.nterm.and.icom.le.nlist) then
#        write(*,*) '<'//FITCOM(ICOM)//'>',ICOM,rm.NTERM
# FIX
        if (fitcom(icom).eq. 'FIX') then               
            if (nos.eq.0.or.(nos.eq.1.and.nint(ret(1)).eq.-1)) then   ! fix all (default)         
              do j=1,rm.nterm
                    jfixed(j)=0
                    rm.fixparam(j)=jfixed(j)
              enddo                
            else if (nos.eq.1.and.nint(ret(1)).eq.0) then  ! free all
              do j=1,rm.nterm
                    jfixed(j)=1
                    rm.fixparam(j)=jfixed(j)
              enddo                            
            else if (nos.gt.0) then 
              do i=1,nos
               ifx=nint(ret(i))
                if (ifx.gt.0.and.ifx.le.rm.nterm) then
                  if (jfixed(ifx).eq.0) then
                    jfixed(ifx)=1
                  else
                    jfixed(ifx)=0
                  endif
                  rm.fixparam(ifx)=jfixed(ifx)
                endif
              enddo 
            endif
            call setmodel(rm)  ! update exci data
            call LISTFITPAR
# PLOT
        else if (fitcom(icom).eq. 'PLOT') then   
#          IF (OLDCHKQOM.NE.CHKQOM) THEN ! QOM array might have chaned by MAPSQ
#             OLDCHKQOM=GETSQOM(1,mf_max,1)
#          ENDIF
          call RESFIT(0)  ! calculate model curve, without fitting (arg=0)
          if (cmenu(lmenu).eq.imenu) lback=.true.  ! indicate single call to a submenu
          call PLOT_CMD( 'SCAN',iq) 
# MAPSQ
        else if (fitcom(icom).eq. 'MAPSQ') then 
          i=swraytr   ! remember SWRAYTR state, it is set to 0 by SQOM 
          if (cmenu(lmenu).eq.imenu) lback=.true.  ! indicate single call to a submenu
          call PLOT_CMD( 'SQOM',iq) 
          swraytr=i
# OMEXC
        else if (fitcom(icom).eq. 'OMEXC') then 
          call REPORTOMEXC 
# INIT
        else if (fitcom(icom).eq. 'INIT') then   
          call INITEXCI(1,1)   ! arg=1 to force parameter file reading          
# RUN
        else if (fitcom(icom).eq. 'RUN') then   
#          IF (OLDCHKQOM.NE.CHKQOM) THEN
#             OLDCHKQOM=GETSQOM(1,mf_max,1)   
#          ENDIF
          itmax=1  ! only one iteration by default
          if (nos.gt.0) itmax=nint(ret(1)) 
          call RESFIT(itmax)
          call LISTFITPAR
        endif
#// update menu: number of parameters may have changed !
        call getmodel(rm) 
        call FIT_CMD_INIT(rm,fitcom,fithint,nlist) 
      endif

      end  


#--------------------------------------------------------
      SUBROUTINE DATA_CMD(scomm,iq)
# Command interpreter for DATA dialog      
# IQ=1 inidicates return to the parent menu (=QUIT) 
#--------------------------------------------------------
      implicit none
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'
      
      character*(*) scomm
      integer*4 iq,nlist,icom,npar,i,i2,n,lcom
      parameter(nlist=6)
      character*5 commands(nlist)
      character*60 hints(nlist)
      character*128 line,LINPEXECSTR
      real*8 pnum(10)
      integer*4 nnum,k
      logical*4 lback  ! indicates return from a submenu (PLOT calls ...)
      data lback/.false./
      data commands / 'OPEN', 'ADD', 'DEL', 'n', 'TAG', 'MC'
      data hints /
     1   '[n1[,n2]] OPEN specified range of data or a list of names',
     2   '[n1[,n2]] ADD new data ...',
     3   '[p1[ p2]] DELETE data from the position p1 to p2',
     5   'set pointer to n-th spectrum/channel ',
     6   '[n] tag/untag the data (n-th or current)',
     7   '[n] calculate R(Q,E) by M.C. for n*1000 events'

      lcom=len_trim(scomm)
      iq=0
#// initialization
      if (imenu.ne.mn_data) then  ! first entry => set LINP with menu items
        imenu=mn_data
        if (lcom.eq.0) then
          if (.not.lback) lmenu=lmenu+1
          cmenu(lmenu)=imenu
        endif
        lback=.false.
        call LINPSET(nlist, 'DATA',commands,hints)
# IPT update to mask data sets which are not active       
        do k=1,mf_max
          mf_loaded(k)=((npt(k)-npt(k-1)).gt.0)
          if (mf_active(k)) then
             do i=npt(k-1)+1,npt(k)
                ipt(i)=k
             enddo
          else
             do i=npt(k-1)+1,npt(k)
                ipt(i)=0
             enddo
          endif     
        enddo
        if (lcom.le.0) call MFIT_LIST
      endif      
      if (lcom.eq.0) return  ! ignore empty commands
     
#// process command through LINP      
      line=LINPEXECSTR(scomm(1:lcom),icom,npar)      

#// Integer number (set pointer):        
      if (icom.eq.-5.and.npar.ne.mf_cur) then
         if (npar.gt.0.and.npar.le.mf_max) then  ! change pointer to mf_cur
            call mfit_set(npar)   ! ensure that RESTRAX has all from new mf_cur dataset
         endif 
      endif

#// standard commands (ICOM=0)
      if(icom.eq.0) then       
# QUIT
           if (line(1:4).eq. 'QUIT') then
             iq=1
# LIST
           else if (line(1:4).eq. 'LIST') then  ! must handle end of input file
             call MFIT_LIST
           endif                
#// identified commands (ICOM>0)
      else if (icom.gt.0.and.icom.le.nlist) then
# OPEN:      
        if (commands(icom).eq. 'OPEN') then    
           call ADDDATA(line,npar,mf_cur,2)
# ADD:
        else if (commands(icom).eq. 'ADD') then    
           call ADDDATA(line,npar,mf_max+1,2)
# DELETE:
        else if (commands(icom).eq. 'DEL') then    
           call GETLINPARG(line,pnum(1),10,nnum)
           i=mf_cur
           if (nnum.gt.0) i=nint(pnum(1))
           i2=i
           if (nnum.gt.1) i2=nint(pnum(2))
           call DELDATA(i,i2)
# TAG:
        else if (commands(icom).eq. 'TAG') then                    
           k=mf_cur
           if (npar.gt.0)  then
               call GETLINPARG(line,pnum(1),10,nnum)
               if (nnum.gt.0) then
                 k=nint(pnum(1))
                 if (k.lt.1.or.k.gt.mf_max) k=mf_cur
               endif  
           endif
           mf_active(k)=(.not.(mf_active(k)))
           if (mf_active(k)) then
                do i=npt(k-1)+1,npt(k)
                   ipt(i)=k
                enddo
           else
                do i=npt(k-1)+1,npt(k)
                  ipt(i)=0
                enddo
           endif     
# MC:
        else if (commands(icom).eq. 'MC') then 
           n=lastnev
           if (npar.gt.0)  then
               call GETLINPARG(line,pnum(1),10,nnum)
               if (nnum.gt.0) then
                n=nint(pnum(1)*1000)
                if (n*mf_max.gt.mqom) n=(mqom/mf_max)-1
               endif  
           endif
           call RUNMC(0,n)             
        endif
      endif         

      end

#--------------------------------------------------------
      SUBROUTINE PLOT_CMD(scomm,iq)
# Command interpreter for plotting results  
# Response to the PLOT command: subcommands will pass through   
# IQ=1 inidicates return to the parent menu (=QUIT) 
# Dialog arguments:
# DLGARG(1)    ... various plot attributes
# DLGSTR(1)    ... plot caption
#--------------------------------------------------------
      implicit none
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'res_grf.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'
      
      character*(*) scomm
      integer*4 iq,nlist,icom,npar
      parameter(nlist=8)
      character*5 commands(nlist)
      character*60 hints(nlist)
      character*128 line,LINPEXECSTR
      integer*4 lcom,i,ic
      character*16 labels
      logical*4 lback  ! indicates return from a submenu (PLOT calls ...)
      data lback/.false./
      
      data labels/ 'h:k:l:dE [meV]'/
           
      data commands / 'SCAN', 'ELL', 'RES', 'CRES', 'MRES', 'SQOM', 'PROF',
     &      'PRINT'
      data hints /
     1   'R(Q,E), dispersion sheet, data & fit (if available)',
     3   'resolution ellipsoids in C&N cooordinates',
     4   'R(Q,E) in C&N cooordinates',
     5   'R(Q,E) in [hklE], CURRENT dataset',
     5   'R(Q,E) in [hklE], ALL datasets',
     6   'Map of S(Q,E) at E=const.',
     7   '[n] R(Q,E) profile along n=ord[h,k,l,E,kf]',
     7   'Print the last graph'

#6     FORMAT('PLOT_CMD ITEM=',I2,' MENU=',I2,' LEVEL=',I2)           

      lcom=len_trim(scomm)
      
      if (swplot.eq.0) then
        write(sout,*)  'graphics output switched off'
        return
      endif

#      write(*,*) 'PLOT_CMD: ',LCOM,SCOMM(1:LCOM)
      iq=0
#// initialization
      if (imenu.ne.mn_plot) then  ! first entry => set LINP with menu items
#      write(*,6) IMENU,CMENU(LMENU),LMENU
        imenu=mn_plot
        if (lcom.eq.0) then
          if (.not.lback) lmenu=lmenu+1
          cmenu(lmenu)=imenu
#      write(*,6) IMENU,CMENU(LMENU),LMENU
        endif
        lback=.false.
        call LINPSET(nlist, 'PLOT',commands,hints)
      endif
      if (lcom.le.0) return  ! ignore empty commands

#// process command through LINP      
      line=LINPEXECSTR(scomm(1:lcom),icom,npar) 
#// get numeric arguments       
      call GETLINPARG(line,ret(1),10,nos)  ! accept up to 10 numerical arguments

#      write(*,*) 'PLOT_ICOM: ',ICOM,(RET(I),I=1,NOS)

# standard commands (ICOM=0)
      if(icom.eq.0) then       
# QUIT
        if (line(1:4).eq. 'QUIT') then
          iq=1
          return
        endif      
      endif

#// If command is an integer => interpret it as command ID        
#// this preserves older behaviour of the PLOT command
      if (icom.eq.-5) then  ! 1st argument is command ID
        do i=1,nos
          grfarg(i-1)=ret(i)
        enddo
        nos=nos-1
        
      else if (icom.gt.0.and.icom.le.nlist) then  ! recognised command
#// copy argumments to GRFARG for all commands except PRINT        
        if (icom.lt.nlist) then
          grfnarg=nos
          do i=1,nos
            grfarg(i)=ret(i)
          enddo
        endif
      else
        return  ! nothing to do
      endif
            
      
# identified commands (ICOM>0)
      if (icom.gt.0.and.icom.le.nlist) then
#        write(*,*) '<'//COMMANDS(ICOM)//'>',(GRFARG(I),I=1,GRFNARG)
#* SCAN
        if (commands(icom).eq. 'SCAN') then    

# comment out = allow empty histograms
#           IF (MOD(WHATHIS,2).EQ.0) THEN ! histogram not ready
#             write(smes,*) 'No data in the histogram. '//
#     &         'Try commands [M]PHON or [M]FIT first.'
#           ELSE IF (mf_max.eq.1) THEN ! single channel - show also R(Q,E)

           if (mf_max.eq.1) then  ! single channel - show also R(Q,E)
             grfarg(0)=4               ! call PAGE2
           else                        ! multiple channels
             if (cfgmode.eq.1) then    ! flat cone => call AB_IMAGE(ig_FCDATA)
               grfarg(0)=-7
             else  
               grfarg(0)=5             ! multiple cells => call PLOT_MDAT
             endif 
           endif
#* SQOM
        else if (commands(icom).eq. 'SQOM') then    
           grfarg(0)=-6                ! call AB_IMAGE(ig_SQOM)
#          write(*,*) 'command is SQOM: ',NINT(GRFARG(0))
#* PROF
        else if (commands(icom).eq. 'PROF') then    
            if (grfnarg.eq.0) grfarg(1)=4  ! scan E by default
#          write(*,*) 'command is PROF: ',NINT(GRFARG(0))
           grfarg(0)=9       ! call VIEWSCAN
#* ELL
        else if (commands(icom).eq. 'ELL') then 
           grfarg(0)=0    ! default = 0, call PAGE1
#          write(*,*) 'command is ELL: ',NINT(GRFARG(0))
           if (grfnarg.gt.0) grfarg(0)=grfarg(1) 
#* RES
        else if (commands(icom).eq. 'RES') then    
           grfarg(0)=3    ! call PAGE1
#          write(*,*) 'command is RES: ',NINT(GRFARG(0))
#* CRES
        else if (commands(icom).eq. 'CRES') then    
          grfarg(0)=-3    ! call RES_IMAGE (mf_cur)
#          write(*,*) 'command is CRES: ',NINT(GRFARG(0))
#* MRES
        else if (commands(icom).eq. 'MRES') then    
          grfarg(0)=-4    ! call RES_IMAGE(0)
#          write(*,*) 'command is MRES: ',NINT(GRFARG(0))
          if (cfgmode.eq.1.and.mf_max.gt.1) grfarg(0)=-5   ! call AB_IMAGE(ig_FCRES) for flat-cone 
#* PRINT
        else if (icom.eq.nlist) then    
           toprint=1
        endif 
      endif  
      
# execute plotting dialogs before graph initialization
      if (toprint.ne.1) then
          ic=nint(grfarg(0))
#       write(*,*) 'PLOT_CMD, GRFARG: ',IC   
          select case (ic)
            case (-3,-4)
              call DLG_RESPLOT(labels,grfarg(1),10,grfstr)
            case (-5,-6,-7)
              if (cmdmode.eq.1) then  ! call elementary dialogs in interactive mode only 
                grfstr= ' '
                call DLG_STRING( 'comment',grfstr,0)    
                call DLG_DOUBLE( 'scale',grfarg(1),1,1.d-2,1.d2) 
              else  ! otherwise use the dialog arrays
                grfstr=dlgstr(1)
                grfarg(1)=dlgarg(1)
              endif
          end select           
      endif

      call MAKEMC( 'PLOT')   ! call Monte Carlo if necessary 
                
# execute the main plotting subroutine        
      call PLOTOUT  ! this is called for all recognized commands

      end


#     --------------------------------------------
      SUBROUTINE SLIT_CMD(obj,scomm,iq)
# IQ=1 inidicates return to the parent menu (=QUIT) 
#     --------------------------------------------
      implicit none
      INCLUDE 'nesobj_slit.inc'
      INCLUDE 'restrax_cmd.inc'
      record /SLIT/ obj
      character*(*) scomm
      character*128 line
      integer*4 iq,icom,npar,i,SLIT_SET,ierr,in,out,err ,lcom 
      character*128 LINPEXECSTR,SLIT_GET
      logical*4 lback  ! indicates return from a submenu (PLOT calls ...)
      data lback/.false./
      data slitcomm / 'NAME', 'SIZE', 'SHAPE', 'POS', 'ORI', 'SHIFT'
      data slithint /
     1   'component name',
     2   'dimensions (x,y,z) [mm]',
     3   '(0) sphere (1) cyllinder (2) disc (3) rectangle',
     4   'distance, take-off angle, sagital angle [mm,deg,deg]',
     5   'orientation along (x,y,z) [deg]',
     6   'linear stage shift (x,y,z) [mm]'
      data nlist /6/   

1     format(a)
      lcom=len_trim(scomm)
      iq=0
#// initialization
      if (imenu.ne.mn_plot) then  ! first entry => set LINP with menu items
        imenu=mn_plot
        if (lcom.eq.0) then
          if (.not.lback) lmenu=lmenu+1
          cmenu(lmenu)=imenu
        endif
        lback=.false.
        call LINPSET(nlist, '  '//obj.name,slitcomm,slithint)
        call LINPGETIO(in,out,err)
      endif
      if (lcom.le.0) return  ! ignore empty commands

#// process command through LINP      
      line=LINPEXECSTR(scomm(1:lcom),icom,npar)

# standard commands (ICOM=0)
      if(icom.eq.0) then       
# QUIT
        if (line(1:4).eq. 'QUIT') then
          iq=1
# LIST
        else if (line(1:4).eq. 'LIST') then
          do i=1,nlist
            call WRITELINE(slitcomm(i)// '  '//SLIT_GET(obj,i),out)
          enddo
          line= ' '           
        endif
# identified commands (ICOM>0)
      else if (icom.gt.0.and.icom.le.nlist) then
        if (npar.eq.0) then
           call WRITELINE(slitcomm(icom)// '  '//SLIT_GET(obj,icom),out)
        else
            ierr=SLIT_SET(obj,slitcomm(icom)// '  '//line)
            if(ierr.eq.-1) then
              write(err,1)  'Incomplete data !'
            else if(ierr.eq.-2) then  
              write(err,1)  'Wrong data !'
            endif
        endif
      endif      
      end