1006 lines
20 KiB
Fortran
Executable File
1006 lines
20 KiB
Fortran
Executable File
SUBROUTINE FIT_COMMAND(input)
|
|
C -----------------------------
|
|
|
|
include 'fit.inc'
|
|
|
|
character INPUT*(*) !! commandfile name, if blank: input from terminal
|
|
|
|
character*5 prompt/'fit> '/
|
|
integer maxlev
|
|
parameter (maxlev=32)
|
|
integer sp, st(maxlev) ! lun stack for nested @
|
|
|
|
integer lun
|
|
logical terminal
|
|
integer rlun, iostat
|
|
character fullm*1
|
|
|
|
external fit_docmd
|
|
|
|
quit=.false.
|
|
sp=0
|
|
if (input .eq. ' ') then
|
|
rlun=isysrd
|
|
terminal=.true.
|
|
else
|
|
terminal=.false.
|
|
rlun=0
|
|
cmdline(1:1)='@'
|
|
cmdline(2:)=input
|
|
linlen=len(input)+1
|
|
sp=0
|
|
goto 20
|
|
endif
|
|
|
|
10 write(isyswr, *)
|
|
11 continue
|
|
12 if (terminal .and. sp .eq. 0) then
|
|
call sys_rd_line(cmdline, linlen, prompt)
|
|
if (linlen .lt. 0) return
|
|
if (linlen .eq. 0) goto 12
|
|
cmdline=cmdline(1:linlen)
|
|
if (cmdline(1:linlen) .eq. ' ') goto 12
|
|
else
|
|
read(rlun, '(a)', end=998, err=998) cmdline
|
|
call str_trim(cmdline, cmdline, linlen)
|
|
if (cmdline(1:linlen) .eq. ' ') goto 12
|
|
write(isyswr, *) prompt, cmdline(1:linlen)
|
|
endif
|
|
|
|
20 if (cmdline(1:1).eq. '@' .and. linlen .gt. 1) then
|
|
|
|
call sys_get_lun(lun)
|
|
if (sp .ge. maxlev .or. lun .lt. 0) then
|
|
write(isyswr,*) 'To many @ nested'
|
|
if (lun .ge. 0) call sys_free_lun(lun)
|
|
else
|
|
call sys_open(lun, cmdline(2:linlen), 'r', iostat) ! readonly
|
|
if (iostat .ne. 0) then
|
|
write(isyswr,*) 'Can not open ',cmdline(2:linlen)
|
|
else
|
|
sp=sp+1
|
|
st(sp)=rlun
|
|
rlun=lun
|
|
endif
|
|
endif
|
|
|
|
else
|
|
|
|
isysrd=rlun
|
|
call sys_getenv('FIT_ERRHANDLING', fullm)
|
|
call str_upcase(fullm, fullm)
|
|
if (fullm .ne. 'N') then
|
|
call sys_try(fit_docmd)
|
|
else
|
|
call fit_docmd
|
|
endif
|
|
isysrd=5
|
|
if (quit) then
|
|
call gra_close !cgt
|
|
return
|
|
endif
|
|
if (autoplot) then
|
|
if (npkt .ne. 0) then
|
|
CALL fit_PLOT('s') ! cgt
|
|
endif
|
|
endif
|
|
|
|
endif
|
|
goto 10
|
|
|
|
998 if (sp .le. 0) return
|
|
close(rlun)
|
|
if (sp .gt. 1) call sys_free_lun(rlun)
|
|
rlun=st(sp)
|
|
if (rlun .eq. 0) return
|
|
sp=sp-1
|
|
goto 11
|
|
|
|
end
|
|
|
|
|
|
|
|
subroutine fit_docmd
|
|
C --------------------
|
|
|
|
implicit none
|
|
include 'fit.inc'
|
|
|
|
real rarg, rpar(maxset)
|
|
character line*8192, opt*32
|
|
integer l,i,iarg,ll
|
|
logical done
|
|
|
|
! functions
|
|
logical arg_check_cmd, arg_check_opt
|
|
|
|
linlen=min(linlen,len(cmdline)-1)
|
|
cmdpos=0
|
|
argok=.true.
|
|
|
|
separator='='
|
|
call arg_gen(i,cmdlen)
|
|
if (i .ne. 0) cmdline(1:i+cmdlen)=cmdline(i+1:i+cmdlen)
|
|
|
|
if (cmdline(cmdpos:cmdpos) .eq. '=') then ! SET can be omitted
|
|
cmdpos=0
|
|
goto 10
|
|
endif
|
|
|
|
do i=nplug,1,-1
|
|
done=.false.
|
|
call sys_call_i(plug_cmds(i), done)
|
|
if (done) return
|
|
enddo
|
|
|
|
if (arg_check_cmd('INFO',1)) then
|
|
|
|
argok=.false.
|
|
call arg_par_sym_num(iarg, i, l)
|
|
if (iarg .eq. 0) then
|
|
iarg=-2
|
|
i=3
|
|
endif
|
|
if (iarg .eq. -2) then ! was number
|
|
call str_trim(fillis, fillis, l)
|
|
print '(x,a,i6,2a)','Ntot=',npkt,'; Filelist=',fillis(1:l)
|
|
call sym_list(isyswr, 1, i, ' ')
|
|
else if (iarg .eq. -1) then ! was name
|
|
call meta_show(cmdline(i+1:i+l))
|
|
else ! was parameter name
|
|
print *,cmdline(i+1:i+l),'=',u(iarg)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('HELP',1)) then
|
|
|
|
call arg_str(line)
|
|
call fit_help(line)
|
|
|
|
elseif (arg_check_cmd('BARS',3)) then
|
|
|
|
call arg_str(line(1:1))
|
|
call fit_bars(line(1:1))
|
|
|
|
elseif (arg_check_cmd('CONNECT',3)) then
|
|
|
|
call arg_str(line(1:1))
|
|
call fit_connect(line(1:1))
|
|
|
|
elseif (arg_check_cmd('STYLE',3)) then
|
|
|
|
call fit_style(0,0)
|
|
|
|
elseif (arg_check_cmd('COLORS',3)) then
|
|
|
|
call arg_int(iarg, 999)
|
|
call fit_colors(iarg)
|
|
if (iarg .eq. 999) then
|
|
print *,'maximum available number of colors used'
|
|
else
|
|
print *,iarg,' colors used'
|
|
endif
|
|
|
|
elseif (arg_check_cmd('NCURVES',7)) then
|
|
|
|
call arg_int(iarg, 0)
|
|
call fit_ncurves(iarg)
|
|
|
|
elseif (arg_check_cmd('LEGEND',3)) then
|
|
|
|
call arg_str(line)
|
|
print *
|
|
call fit_legend(line)
|
|
if (line(1:1) .eq. '@') then
|
|
print '(x,2(a,f5.1))','draw legend at ',legendx, ',',legendy
|
|
elseif (legend .ge. 1) then
|
|
print *,'draw legend using ',userpar(usernp+legend)
|
|
elseif (legend .lt. 0) then
|
|
print *,'draw custom legend'
|
|
else
|
|
print *,'draw no legend'
|
|
endif
|
|
|
|
elseif (arg_check_cmd('ERR',3)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
if (argok) call fit_err(rarg)
|
|
|
|
elseif (arg_check_cmd('RESERR',5)) then
|
|
|
|
call fit_reserr
|
|
|
|
elseif (arg_check_cmd('EPSI',3)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
if (argok) call fit_epsi(rarg)
|
|
|
|
elseif (arg_check_cmd('VTEST',4)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
if (argok) call fit_vtest(rarg)
|
|
|
|
elseif (arg_check_cmd('PRI',3)) then
|
|
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_pri(iarg)
|
|
|
|
elseif (arg_check_cmd('DAT',3)) then
|
|
|
|
call arg_str(line)
|
|
call fit_dat(line)
|
|
|
|
elseif (arg_check_cmd('RANGE',3)) then
|
|
|
|
call arg_real(rpar(1), 0.0)
|
|
call arg_real(rpar(2), 0.0)
|
|
call arg_str(line)
|
|
call fit_range(rpar(1), rpar(2), line)
|
|
|
|
elseif (arg_check_cmd('OPTIONS',3)) then
|
|
|
|
call arg_str(line)
|
|
call fit_dat_options(line)
|
|
|
|
elseif (arg_check_cmd('LINK',4)) then
|
|
|
|
call arg_str(line)
|
|
call fit_link(line)
|
|
|
|
elseif (arg_check_cmd('NEXT',1)) then
|
|
|
|
call fit_dat(' ')
|
|
call fit_mon(0.)
|
|
call fit_win(0.0,0.0)
|
|
call fit_bars(' ')
|
|
call fit_fun(-1,0,0.0,0.0)
|
|
|
|
elseif (arg_check_cmd('MERGE',3)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
if (argok) then
|
|
call fit_merge(rarg)
|
|
call fit_auto_mon
|
|
endif
|
|
|
|
elseif (arg_check_cmd('SUBTRACT',3)) then
|
|
|
|
call arg_str(line)
|
|
call fit_subtract(line)
|
|
|
|
elseif (arg_check_cmd('ADD',3)) then
|
|
|
|
do i=1,maxset
|
|
call arg_real(rpar(i), 1.0)
|
|
enddo
|
|
if (argok) then
|
|
call fit_add(rpar,maxset)
|
|
else
|
|
print *
|
|
1,'Command ADD: add one or more constant(s) to the dataset(s)'
|
|
print *,'Use command LINK to link new data.'
|
|
print *
|
|
endif
|
|
|
|
elseif (arg_check_cmd('MULTIPLY',3)) then
|
|
|
|
do i=1,maxset
|
|
call arg_real(rpar(i), 1.0)
|
|
enddo
|
|
if (argok) call fit_multiply(rpar,maxset)
|
|
|
|
elseif (arg_check_cmd('ABSKOR',3)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
call arg_real(rpar(1), 0.0)
|
|
if (argok) call fit_abskor(rarg, rpar(1))
|
|
|
|
elseif (arg_check_cmd('TRANS',5)) then
|
|
|
|
call arg_lit(opt)
|
|
call arg_real(rarg, 0.0)
|
|
call fit_trans(opt, rarg)
|
|
|
|
elseif (arg_check_cmd('PLOG',4)) then
|
|
|
|
call arg_real(rarg, shift(1))
|
|
call fit_plog(1, rarg)
|
|
print *,'plots with logarithmic y-axis'
|
|
|
|
elseif (arg_check_cmd('PLIN',4)) then
|
|
|
|
call arg_real(rarg, shift(0))
|
|
call fit_plog(0, rarg)
|
|
print *,'plots with linear y-axis'
|
|
|
|
elseif (arg_check_cmd('PLOT',1)) then
|
|
|
|
call arg_lit(opt)
|
|
call str_upcase(opt,opt)
|
|
if (arg_check_opt(opt, 'AUTO', 1) .or.
|
|
1 arg_check_opt(opt, '1', 1)) then
|
|
autoplot = .true.
|
|
call sys_setenv('FIT_AUTOPLOT', '1')
|
|
call sys_saveenv
|
|
return
|
|
elseif (arg_check_opt(opt, 'OFF', 1) .or.
|
|
1 arg_check_opt(opt, '0', 1)) then
|
|
autoplot = .false.
|
|
call sys_setenv('FIT_AUTOPLOT', '0')
|
|
call sys_saveenv
|
|
call gra_close !cgt
|
|
return
|
|
endif
|
|
if (arg_check_opt(opt, 'YES', 1) .or.
|
|
1 arg_check_opt(opt, 'PRINT', 1)) then
|
|
opt='Y'
|
|
else
|
|
opt=' '
|
|
endif
|
|
if (nxmin .ge. nxmax) then
|
|
if (npkt .eq. 0) then
|
|
write(isyswr, *) 'no data loaded'
|
|
else
|
|
write(isyswr,*)'no data points present - enlarge fit window'
|
|
endif
|
|
else
|
|
if (autoplot) call gra_close
|
|
CALL fit_PLOT(opt)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('BGEDIT', 2)) then
|
|
|
|
call arg_str(line)
|
|
call fit_bgedit(line)
|
|
|
|
elseif (arg_check_cmd('CHOOSER',3)) then
|
|
|
|
call cho_choose('?')
|
|
|
|
elseif (arg_check_cmd('SCALE',2)) then
|
|
|
|
do i=1,4
|
|
call arg_real(rpar(i), 0.0)
|
|
enddo
|
|
if (argok) call fit_scale(rpar(1),rpar(2),rpar(3),rpar(4))
|
|
|
|
elseif (arg_check_cmd('RSC',3)) then
|
|
|
|
call fit_rsc
|
|
|
|
elseif (arg_check_cmd('TITLE',3)) then
|
|
|
|
call arg_str(line)
|
|
CALL fit_TITLE(line)
|
|
|
|
elseif (arg_check_cmd('MON',3)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
if (argok .and. nxmin .lt. nxmax) call fit_mon(rarg)
|
|
|
|
elseif (arg_check_cmd('USEMON',3)) then
|
|
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_usemon(iarg)
|
|
|
|
elseif (arg_check_cmd('FUN',3)) then
|
|
|
|
if (nxmin .ge. nxmax) then
|
|
if (npkt .eq. 0) then
|
|
write(isyswr, *) 'no data loaded'
|
|
else
|
|
write(isyswr,*)'no data points present - enlarge fit window'
|
|
endif
|
|
else
|
|
call arg_int(iarg, -1)
|
|
if (argok) call fit_fun(iarg,0,0.0,0.0)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('AUTO',2)) then
|
|
|
|
call fit_auto
|
|
|
|
elseif (arg_check_cmd('NEWPEAK',3)) then
|
|
|
|
if (nu .gt. 0) call fit_newpeak
|
|
|
|
elseif (arg_check_cmd('LOAD',4)) then
|
|
|
|
call arg_str(line)
|
|
if (line .eq. ' ') then
|
|
write(isyswr, '(/X,A/X,A,$)') 'Load parameter-file'
|
|
1 , 'Filename: '
|
|
read(isysrd, '(a)',end=999,err=999) line
|
|
endif
|
|
if (line .ne. ' ') call fit_load(line)
|
|
|
|
elseif (arg_check_cmd('FIT',1)) then
|
|
|
|
if (nu .le. 0) then
|
|
write(isyswr, *) 'Nothing to fit'
|
|
else
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_fit(iarg)
|
|
endif
|
|
|
|
c elseif (arg_check_cmd('TEST',1)) then
|
|
c
|
|
c call fit_test
|
|
|
|
elseif (arg_check_cmd('MIN',1)) then
|
|
|
|
if (nu .le. 0) then
|
|
write(isyswr, *) 'Nothing to fit'
|
|
else
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_min(iarg)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('MIG',3)) then
|
|
|
|
if (nu .le. 0) then
|
|
write(isyswr, *) 'Nothing to fit'
|
|
else
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_mig(iarg)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('SIM',3)) then
|
|
|
|
if (nu .le. 0) then
|
|
write(isyswr, *) 'Nothing to fit'
|
|
else
|
|
call arg_int(iarg, 0)
|
|
if (argok) call fit_sim(iarg)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('TRUERR',3)) then
|
|
|
|
call arg_par(iarg)
|
|
call arg_real(rarg, 1.0)
|
|
if (argok) call fit_true_err(iarg,rarg)
|
|
|
|
elseif (arg_check_cmd('COVAR',3)) then
|
|
|
|
call fit_covar
|
|
|
|
elseif (arg_check_cmd('SET',3)) then
|
|
|
|
goto 10
|
|
|
|
elseif (arg_check_cmd('LIM',3)) then
|
|
|
|
call arg_par(iarg)
|
|
call arg_real(rpar(1), 0.0)
|
|
call arg_real(rpar(2), 0.0)
|
|
if (argok) then
|
|
call fit_lim(iarg, rpar(1), rpar(2))
|
|
call fit_print(1)
|
|
endif
|
|
|
|
elseif (arg_check_cmd('FIX',3)) then
|
|
|
|
call arg_par(iarg)
|
|
if (argok) call fit_fix(iarg)
|
|
call arg_par(iarg)
|
|
do while (argok .and. iarg .ne. 0)
|
|
call fit_fix(iarg)
|
|
call arg_par(iarg)
|
|
enddo
|
|
|
|
elseif (arg_check_cmd('COR',3)) then
|
|
|
|
separator='='
|
|
call arg_par(iarg)
|
|
separator='*'
|
|
call arg_par(i)
|
|
separator='+'
|
|
call arg_real(rarg, 1.0)
|
|
call arg_real(rpar(1), 0.0)
|
|
if (argok) call fit_cor(iarg, i, rarg, rpar(1))
|
|
|
|
elseif (arg_check_cmd('REL',3)) then
|
|
|
|
call arg_par(iarg)
|
|
if (argok) call fit_rel(iarg)
|
|
call arg_par(iarg)
|
|
do while (argok .and. iarg .ne. 0)
|
|
call fit_rel(iarg)
|
|
call arg_par(iarg)
|
|
enddo
|
|
|
|
elseif (arg_check_cmd('WIN',1)) then
|
|
|
|
call arg_real(rarg, 0.0)
|
|
call arg_real(rpar(2), 0.0)
|
|
if (argok) CALL fit_win(rarg, rpar(2))
|
|
|
|
elseif (arg_check_cmd('EXCLUDE', 4)) then
|
|
|
|
do i=1,4
|
|
call arg_real(rpar(i), 0.0)
|
|
enddo
|
|
if (argok) call fit_exclude(rpar(1),rpar(2),rpar(3),rpar(4))
|
|
|
|
elseif (arg_check_cmd('INCLUDE', 4)) then
|
|
|
|
do i=1,4
|
|
call arg_real(rpar(i), 0.0)
|
|
enddo
|
|
if (argok) call fit_include(rpar(1),rpar(2),rpar(3),rpar(4))
|
|
|
|
elseif (arg_check_cmd('KEEP',4)) then
|
|
|
|
call arg_str(line(1:1))
|
|
call fit_keep(line(1:1))
|
|
|
|
elseif (arg_check_cmd('FILE',4)) then
|
|
|
|
call arg_str(line)
|
|
rarg=0
|
|
read(line,'(f20.0)',err=11,end=11) rarg
|
|
l=index(line,',')
|
|
if (l .eq. 0) goto 11
|
|
line=line(l+1:)
|
|
11 call fit_file(rarg, line)
|
|
|
|
elseif (arg_check_cmd('EXPORT',3)) then
|
|
|
|
call arg_lit(opt)
|
|
rarg=0
|
|
read(opt,*,err=12,end=12) rarg
|
|
call arg_lit(opt)
|
|
12 call arg_str(line)
|
|
call fit_export(rarg, opt, line)
|
|
|
|
elseif (arg_check_cmd('FCN',3)) then
|
|
|
|
call fit_check_range
|
|
call fnctn(x,amin)
|
|
call fit_print(1)
|
|
|
|
elseif (arg_check_cmd('LIST',1)) then
|
|
|
|
CALL fit_LIST
|
|
|
|
elseif (arg_check_cmd('OUT',3)) then
|
|
|
|
if (nu .le. 0) then
|
|
write(isyswr, *) 'Nothing to save'
|
|
else
|
|
CALL fit_OUT
|
|
endif
|
|
|
|
elseif (arg_check_cmd('WRITE',5)) then
|
|
|
|
call fit_write(' ')
|
|
|
|
elseif (arg_check_cmd('K',1)) then
|
|
|
|
call fit_write(' ')
|
|
|
|
elseif (arg_check_cmd('OPEN',4)) then
|
|
|
|
call arg_str(line)
|
|
call fit_write(line)
|
|
|
|
elseif (arg_check_cmd('SAVE',4)) then
|
|
|
|
call arg_str(line)
|
|
call fit_save(line)
|
|
|
|
elseif (arg_check_cmd('FULLMESS',4)) then ! on error write full message and exit
|
|
|
|
call sys_setenv('FIT_ERRHANDLING', 'N')
|
|
call sys_saveenv
|
|
|
|
elseif (arg_check_cmd('EXIT',2) .or. arg_check_cmd('BYE',3)) then
|
|
|
|
quit=.true.
|
|
|
|
elseif (arg_check_cmd('QUIT',2) .or. arg_check_cmd('END',3)) then
|
|
|
|
call gra_print
|
|
stop 'quit FIT'
|
|
|
|
else
|
|
|
|
write(isyswr, '(/5X,3A)' )
|
|
1 'Unknown command: "',cmdline(1:cmdlen),'"'
|
|
|
|
endif
|
|
|
|
return
|
|
|
|
999 print *,'input error'
|
|
return
|
|
|
|
! SET command
|
|
|
|
10 separator='='
|
|
call arg_par_sym_num(iarg, i, l)
|
|
if (iarg .eq. -2) iarg=i ! was parameter number
|
|
if (iarg .eq. -1) then ! was name
|
|
call arg_str(line)
|
|
argok=.false.
|
|
call arg_real(rarg, none)
|
|
if (rarg .ne. none .and. cmdline(cmdpos+1:) .eq. ' ') then
|
|
call fit_put_real(cmdline(i+1:i+l), rarg)
|
|
call meta_show(cmdline(i+1:i+l))
|
|
else
|
|
call str_trim(line, line, ll)
|
|
call fit_put_str(cmdline(i+1:i+l), line(1:ll))
|
|
if (cmdline(i+1:i+l) .eq. 'TITLE') then
|
|
itit=line(1:ll)
|
|
endif
|
|
call meta_show(cmdline(i+1:i+l))
|
|
endif
|
|
return
|
|
endif
|
|
call arg_real(rpar(1), 0.0)
|
|
call arg_real(rpar(2),-1.0)
|
|
call arg_real(rpar(3), 0.0)
|
|
call arg_real(rpar(4),-1.0)
|
|
if (argok) then
|
|
call fit_set(iarg, rpar(1), rpar(2), rpar(3), rpar(4))
|
|
call fit_print(1)
|
|
endif
|
|
end
|
|
|
|
|
|
|
|
logical function arg_check_cmd(name, abbr)
|
|
! ------------------------------------------
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
character name*(*) ! test for that name
|
|
integer abbr ! minimum characters for abbreviation
|
|
|
|
arg_check_cmd=name(1:min(cmdlen,len(name))) .eq. cmdline(1:cmdlen)
|
|
1 .and. cmdlen .ge. abbr
|
|
end
|
|
|
|
|
|
|
|
logical function arg_check_opt(opt, name, abbr)
|
|
! -----------------------------------------------
|
|
|
|
implicit none
|
|
|
|
character opt*(*) ! test option
|
|
character name*(*) ! for that name
|
|
integer abbr ! minimum characters for abbreviation
|
|
|
|
integer l
|
|
|
|
call str_trim(opt, opt, l)
|
|
l=min(l, len(name))
|
|
arg_check_opt=name(1:l) .eq. opt(1:l) .and. l .ge. abbr
|
|
end
|
|
|
|
|
|
|
|
subroutine arg_gen(start, length)
|
|
! ---------------------------------
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
integer start, length
|
|
|
|
integer p,l,ispc,icom,isep
|
|
|
|
p=cmdpos
|
|
l=linlen
|
|
|
|
if (p .ge. l) goto 9
|
|
do while (cmdline(p+1:p+1) .eq. ' ')
|
|
p=p+1
|
|
if (p .ge. l) goto 9
|
|
enddo
|
|
start=p
|
|
! find separator (one of space, comma, custom separator)
|
|
ispc=index(cmdline(p+1:l), ' ')
|
|
if (ispc .eq. 0) ispc=l+1
|
|
icom=index(cmdline(p+1:l), ',')
|
|
if (icom .eq. 0) icom=l+1
|
|
isep=index(cmdline(p+1:l), separator)
|
|
if (isep .eq. 0) isep=l+1
|
|
|
|
p=start+min(ispc,icom,isep)-1
|
|
|
|
length=max(1,p-start)
|
|
! skip spaces
|
|
do while (cmdline(p+1:p+1) .eq. ' ')
|
|
p=p+1
|
|
if (p .ge. l) goto 2
|
|
enddo
|
|
2 if (cmdline(p+1:p+1) .eq. ',' .or.
|
|
1 cmdline(p+1:p+1) .eq. separator) p=p+1
|
|
call str_upcase(cmdline(start+1:p),cmdline(start+1:p))
|
|
cmdpos=p
|
|
separator=','
|
|
return
|
|
|
|
9 length=1
|
|
start=p
|
|
separator=','
|
|
end
|
|
|
|
|
|
subroutine arg_err(start)
|
|
! -------------------------
|
|
|
|
implicit none
|
|
include 'fit.inc'
|
|
integer start
|
|
|
|
character tab*132/' '/
|
|
|
|
if (argok) then
|
|
print '(6x,a)',cmdline(1:linlen)
|
|
print '(5x,a,a)',tab(1:start+1),'^ syntax error'
|
|
cmdpos=linlen
|
|
argok=.false.
|
|
endif
|
|
end
|
|
|
|
|
|
|
|
|
|
subroutine arg_real(rarg, rdefault)
|
|
! -----------------------------------
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
real rarg, rdefault
|
|
integer p,l,j
|
|
character rfmt*12
|
|
|
|
call arg_gen(p,l)
|
|
if (cmdline(p+1:p+l) .eq. ' ') then
|
|
rarg=rdefault
|
|
else
|
|
do j=1,nu
|
|
if (cmdline(p+1:p+l) .eq. psho(j) .or.
|
|
1 cmdline(p+1:p+l) .eq. pnam(j)) then
|
|
rarg=u(j)
|
|
return
|
|
endif
|
|
enddo
|
|
write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)'
|
|
read(cmdline(p+1:p+l), rfmt, err=91,end=91) rarg
|
|
endif
|
|
return
|
|
91 call arg_err(p)
|
|
rarg=rdefault
|
|
end
|
|
|
|
|
|
|
|
subroutine arg_int(iarg, idefault)
|
|
! ----------------------------------
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
integer iarg, idefault
|
|
|
|
integer p,l
|
|
real r
|
|
character rfmt*12
|
|
|
|
call arg_gen(p,l)
|
|
if (cmdline(p+1:p+l) .eq. ' ') then
|
|
iarg=idefault
|
|
else
|
|
write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)'
|
|
read(cmdline(p+1:p+l), rfmt, err=91,end=91) r
|
|
iarg=nint(r)
|
|
if (abs(r-iarg) .gt. abs(r/1e5)) goto 91
|
|
endif
|
|
return
|
|
91 call arg_err(p)
|
|
iarg=idefault
|
|
end
|
|
|
|
|
|
function get_par_no(parname)
|
|
! ----------------------------
|
|
implicit none
|
|
include 'fit.inc'
|
|
|
|
character*(*) parname
|
|
|
|
integer get_par_no
|
|
integer j
|
|
real r
|
|
character rfmt*12
|
|
|
|
do j=1,nu
|
|
if (parname .eq. psho(j) .or.
|
|
1 parname .eq. pnam(j)) then
|
|
get_par_no = j
|
|
return
|
|
endif
|
|
enddo
|
|
write(rfmt, '(a,i2,a)') '(BN,F',len(parname),'.0)'
|
|
read(parname, rfmt, err=91,end=91) r
|
|
get_par_no=nint(r)
|
|
if (r .lt. 0 .or. abs(r-get_par_no) .gt. abs(r/1e5)) goto 91
|
|
return
|
|
|
|
91 get_par_no = 0
|
|
end
|
|
|
|
|
|
subroutine arg_par(iarg)
|
|
! ------------------------
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
integer iarg
|
|
|
|
integer p,l,j
|
|
real r
|
|
character rfmt*12
|
|
integer get_par_no
|
|
|
|
call arg_gen(p,l)
|
|
if (cmdline(p+1:p+l) .eq. ' ') then
|
|
iarg=0
|
|
else
|
|
iarg = get_par_no(cmdline(p+1:p+l))
|
|
if (iarg .le. 0) then
|
|
call arg_err(p)
|
|
iarg=0
|
|
endif
|
|
endif
|
|
return
|
|
end
|
|
|
|
|
|
subroutine arg_par_sym_num(iarg, p, l)
|
|
! --------------------------------------
|
|
!
|
|
! returns: iarg = -2: p is given number
|
|
! iarg = -1: cmdline(p+1:p+l) is literal
|
|
! iarg = 0: empty argument
|
|
! iarg > 0: parameter number of given parameter name cmdline(p+1:p+l)
|
|
!
|
|
|
|
implicit none
|
|
|
|
include 'fit.inc'
|
|
|
|
integer iarg, p,l
|
|
|
|
integer j
|
|
real r
|
|
character rfmt*12
|
|
|
|
call arg_gen(p,l)
|
|
if (cmdline(p+1:p+l) .eq. ' ') then
|
|
iarg=0
|
|
else
|
|
do j=1,nu
|
|
if (cmdline(p+1:p+l) .eq. psho(j) .or.
|
|
1 cmdline(p+1:p+l) .eq. pnam(j)) then
|
|
iarg=j
|
|
return
|
|
endif
|
|
enddo
|
|
if (ni .gt. 0 .and. cmdline(p+1:p+l) .eq. 'INTEXP') then
|
|
iarg = nu + ni
|
|
return
|
|
endif
|
|
write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)'
|
|
read(cmdline(p+1:p+l), rfmt, err=91,end=91) r
|
|
p=nint(r)
|
|
if (abs(r-p) .gt. abs(r/1e5)) goto 91
|
|
iarg=-2
|
|
endif
|
|
return
|
|
91 iarg=-1
|
|
end
|
|
|
|
|
|
subroutine arg_str(str)
|
|
! -----------------------
|
|
!
|
|
! this function does NOT step forward to the next item
|
|
! as it must be the last argument
|
|
!
|
|
implicit none
|
|
include 'fit.inc'
|
|
|
|
character str*(*)
|
|
integer i,p
|
|
|
|
if (cmdpos .lt. linlen) then
|
|
if (cmdline(cmdpos+1:cmdpos+1) .eq. '"' .or.
|
|
1 cmdline(cmdpos+1:cmdpos+1) .eq. '''') then
|
|
p=cmdpos+1
|
|
if (p .lt. linlen) then
|
|
i=index(cmdline(p+1:),cmdline(p:p))
|
|
if (i .eq. 1) then
|
|
str=' '
|
|
else if (i .eq. 0) then
|
|
str=cmdline(p+1:linlen)
|
|
else
|
|
str=cmdline(p+1:p+i-1)
|
|
endif
|
|
else
|
|
str=' '
|
|
endif
|
|
else
|
|
call str_first_nonblank(cmdline(cmdpos+1:linlen),i)
|
|
if (i .eq. 0) i=1
|
|
str=cmdline(cmdpos+i:linlen)
|
|
endif
|
|
else
|
|
str=' '
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine arg_lit(str)
|
|
! -----------------------
|
|
|
|
implicit none
|
|
include 'fit.inc'
|
|
|
|
character str*(*)
|
|
integer l,i
|
|
|
|
if (cmdpos .lt. linlen) then
|
|
l=index(cmdline(cmdpos+1:linlen),',')
|
|
if (l .eq. 0) then
|
|
call str_first_nonblank(cmdline(cmdpos+1:linlen),i)
|
|
if (i .eq. 0) i=1
|
|
str=cmdline(cmdpos+i:linlen)
|
|
cmdpos=linlen
|
|
else
|
|
if (l .eq. 1) then
|
|
str=' '
|
|
else
|
|
call str_first_nonblank(cmdline(cmdpos+1:cmdpos+l-1),i)
|
|
if (i .eq. 0) i=1
|
|
str=cmdline(cmdpos+i:cmdpos+l-1)
|
|
endif
|
|
cmdpos=cmdpos+l
|
|
endif
|
|
else
|
|
str=' '
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine fit_usercmd(sub)
|
|
|
|
include 'fit.inc'
|
|
external sub
|
|
|
|
integer i,funno
|
|
integer sys_adr_i
|
|
|
|
if (nplug+1 .gt. maxplug) then
|
|
print *,'too much plug-in commands'
|
|
RETURN
|
|
endif
|
|
funno=sys_adr_i(sub)
|
|
do i=1,nplug
|
|
if (plug_cmds(i) .eq. funno) RETURN
|
|
enddo
|
|
nplug=nplug+1
|
|
plug_cmds(nplug)=funno
|
|
end
|