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