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