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