mnexcm.f

Go to the documentation of this file.

*
* $Id: mnexcm.F,v 1.2 1996/03/15 18:02:45 james Exp $
*
* $Log: mnexcm.F,v $
* Revision 1.2  1996/03/15 18:02:45  james
*     Modified Files:
* mnderi.F eliminate possible division by zero
* mnexcm.F suppress print on STOP when print flag=-1
*          set FVAL3 to flag if FCN already called with IFLAG=3
* mninit.F set version 96.03
* mnlims.F remove arguments, not needed
* mnmigr.F VLEN -> LENV in debug print statement
* mnparm.F move call to MNRSET to after NPAR redefined, to zero all
* mnpsdf.F eliminate possible division by zero
* mnscan.F suppress printout when print flag =-1
* mnset.F  remove arguments in call to MNLIMS
* mnsimp.F fix CSTATU so status is PROGRESS only if new minimum
* mnvert.F eliminate possible division by zero
*
* Revision 1.1.1.1  1996/03/07 14:31:29  mclareni
* Minuit
*
*
      SUBROUTINE mnexcm(FCN,COMAND,PLIST,LLIST,IERFLG,FUTIL)
*
* $Id: d506dp.inc,v 1.1.1.1 1996/03/07 14:31:32 mclareni Exp $
*
* $Log: d506dp.inc,v $
* Revision 1.1.1.1  1996/03/07 14:31:32  mclareni
* Minuit
*
*
*
*
* d506dp.inc
*
C ************ DOUBLE PRECISION VERSION *************
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
CC        Interprets a command and takes appropriate action,
CC        either directly by skipping to the corresponding code in
CC        MNEXCM, or by setting up a call to a subroutine
CC
*
* $Id: d506cm.inc,v 1.1.1.1 1996/03/07 14:31:32 mclareni Exp $
*
* $Log: d506cm.inc,v $
* Revision 1.1.1.1  1996/03/07 14:31:32  mclareni
* Minuit
*
*
*
*
* d506cm.inc
*
      parameter(mne=100 , mni=50)
      parameter(mnihl=mni*(mni+1)/2)
      CHARACTER*10 CPNAM
      COMMON
     1/mn7nam/ cpnam(mne)
     2/mn7ext/ u(mne)     ,alim(mne)  ,blim(mne)
     3/mn7err/ erp(mni)   ,ern(mni)   ,werr(mni)  ,globcc(mni)
     4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni)
     5/mn7int/ x(mni)     ,xt(mni)    ,dirin(mni)
     6/mn7fx2/ xs(mni)    ,xts(mni)   ,dirins(mni)
     7/mn7der/ grd(mni)   ,g2(mni)    ,gstep(mni) ,gin(mne) ,dgrd(mni)
     8/mn7fx3/ grds(mni)  ,g2s(mni)   ,gsteps(mni)
     9/mn7fx1/ ipfix(mni) ,npfix
     a/mn7var/ vhmat(mnihl)
     b/mn7vat/ vthmat(mnihl)
     c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni)
C
      parameter(maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101)
      parameter(zero=0.0,  one=1.0,   half=0.5)
      COMMON
     d/mn7npr/ maxint ,npar   ,maxext ,nu
     e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag
     e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr
     f/mn7tit/ cfrom  ,cstatu ,ctitl  ,cword  ,cundef ,cvrsn ,covmes
     g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd
     h/mn7min/ amin   ,up     ,edm    ,fval3  ,epsi   ,apsi  ,dcovar
     i/mn7cnv/ nfcn   ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2)
     j/mn7arg/ word7(maxp)
     k/mn7log/ lwarn  ,lrepor ,limset ,lnolim ,lnewmn ,lphead
     l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt
     m/mn7rpt/ xpt(maxcpt)    ,ypt(maxcpt)
     n/mn7cpt/ chpt(maxcpt)
     o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr  ,ke2cr
      CHARACTER CTITL*50, CWORD*(maxcwd), CUNDEF*10, CFROM*8,
     +          cvrsn*6,  covmes(0:3)*22, cstatu*10, chpt*1
      LOGICAL   LWARN, LREPOR, LIMSET, LNOLIM, LNEWMN, LPHEAD
      EXTERNAL fcn,futil
      CHARACTER*(*) COMAND
C   Cannot say DIMENSION PLIST(LLIST) since LLIST can be =0.
      dimension plist(*)
      parameter(mxpt=101)
      dimension xptu(mxpt), yptu(mxpt)
C  alphabetical order of command names!
      CHARACTER*10 CNAME(40), CNEWAY, CHWHY*18, C26*30, CVBLNK*2
      LOGICAL LTOFIX, LFIXED, LFREED
C
      CHARACTER COMD*4
      CHARACTER CLOWER*26, CUPPER*26
      DATA clower/'abcdefghijklmnopqrstuvwxyz'/
      DATA cupper/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
C
C  recognized MINUIT commands:
      DATA cname( 1) / 'MINImize  ' /
      DATA cname( 2) / 'SEEk      ' /
      DATA cname( 3) / 'SIMplex   ' /
      DATA cname( 4) / 'MIGrad    ' /
      DATA cname( 5) / 'MINOs     ' /
      DATA cname( 6) / 'SET xxx   ' /
      DATA cname( 7) / 'SHOw xxx  ' /
      DATA cname( 8) / 'TOP of pag' /
      DATA cname( 9) / 'FIX       ' /
      DATA cname(10) / 'REStore   ' /
      DATA cname(11) / 'RELease   ' /
      DATA cname(12) / 'SCAn      ' /
      DATA cname(13) / 'CONtour   ' /
      DATA cname(14) / 'HESse     ' /
      DATA cname(15) / 'SAVe      ' /
      DATA cname(16) / 'IMProve   ' /
      DATA cname(17) / 'CALl fcn  ' /
      DATA cname(18) / 'STAndard  ' /
      DATA cname(19) / 'END       ' /
      DATA cname(20) / 'EXIt      ' /
      DATA cname(21) / 'RETurn    ' /
      DATA cname(22) / 'CLEar     ' /
      DATA cname(23) / 'HELP      ' /
      DATA cname(24) / 'MNContour ' /
      DATA cname(25) / 'STOp      ' /
      DATA cname(26) / 'JUMp      ' /
      DATA cname(27) / '          ' /
      DATA cname(28) / '          ' /
      DATA cname(29) / '          ' /
      DATA cname(30) / '          ' /
      DATA cname(31) / '          ' /
      DATA cname(32) / '          ' /
      DATA cname(33) / '          ' /
C  obsolete commands:
      DATA cname(34) / 'COVARIANCE' /
      DATA cname(35) / 'PRINTOUT  ' /
      DATA cname(36) / 'GRADIENT  ' /
      DATA cname(37) / 'MATOUT    ' /
      DATA cname(38) / 'ERROR DEF ' /
      DATA cname(39) / 'LIMITS    ' /
      DATA cname(40) / 'PUNCH     ' /
      DATA nntot/40/
C      IERFLG is now (94.5) defined the same as ICONDN in MNCOMD
CC            = 0: command executed normally
CC              1: command is blank, ignored
CC              2: command line unreadable, ignored
CC              3: unknown command, ignored
CC              4: abnormal termination (e.g., MIGRAD not converged)
CC              9: reserved
CC             10: END command
CC             11: EXIT or STOP command
CC             12: RETURN command
      lk = len(comand)
      IF (lk .GT. maxcwd) lk=maxcwd
      cword = comand(1:lk)
C              get upper case
      DO 16 icol= 1, lk
        DO 15 let= 1, 26
        IF (cword(icol:icol) .EQ. clower(let:let))
     +      cword(icol:icol) = cupper(let:let)
   15   CONTINUE
   16 CONTINUE
C           Copy the first MAXP arguments into COMMON (WORD7), making
C           sure that WORD7(1)=0. if LLIST=0
      DO 20 iw= 1, maxp
      word7(iw) = zero
      IF (iw .LE. llist) word7(iw) = plist(iw)
   20 CONTINUE
      icomnd = icomnd + 1
      nfcnlc = nfcn
      IF (cword(1:7).NE.'SET PRI' .OR. word7(1).GE.0.)  THEN
        IF (isw(5) .GE. 0) THEN
         lnow = llist
         IF (lnow .GT. 4)  lnow=4
         WRITE (isyswr,25) icomnd,cword(1:lk),(plist(i),i=1,lnow)
   25    FORMAT (1h ,10(1h*)/' **',i5,' **',a,4g12.4)
         inonde = 0
         IF (llist .GT. lnow) THEN
           kll = llist
           IF (llist .GT. maxp) THEN
              inonde = 1
              kll = maxp
           ENDIF
           WRITE (cvblnk,'(I2)') lk
           c26 = '(11H **********,'//cvblnk//'X,4G12.4)'
           WRITE (isyswr,c26) (plist(i),i=lnow+1,kll)
         ENDIF
         WRITE (isyswr, '(1H ,10(1H*))' )
         IF (inonde .GT. 0)  WRITE (isyswr, '(1H ,10(1H*),A,I3,A)')
     +        '  ERROR: ABOVE CALL TO MNEXCM TRIED TO PASS MORE THAN ',
     +        maxp,' PARAMETERS.'
        ENDIF
      ENDIF
      nfcnmx = word7(1)
      IF (nfcnmx .LE. 0)  nfcnmx = 200 + 100*npar + 5*npar**2
      epsi = word7(2)
      IF (epsi .LE. zero)  epsi = 0.1 * up
      lnewmn = .false.
      lphead = .true.
      isw(1) = 0
      ierflg = 0
C                look for command in list CNAME . . . . . . . . . .
      DO 80 i= 1, nntot
      IF (cword(1:3) .EQ. cname(i)(1:3))  GO TO 90
   80 CONTINUE
      WRITE (isyswr,'(11X,''UNKNOWN COMMAND IGNORED:'',A)') comand
      ierflg = 3
      GO TO 5000
C                normal case: recognized MINUIT command . . . . . . .
   90 CONTINUE
      IF (cword(1:4) .EQ. 'MINO') i = 5
      IF (i.NE.6 .AND. i.NE.7 .AND. i.NE.8 .AND. i.NE.23)  THEN
         cfrom = cname(i)
         nfcnfr = nfcn
      ENDIF
C              1    2    3    4    5    6    7    8    9   10
      GO TO ( 400, 200, 300, 400, 500, 700, 700, 800, 900,1000,
     1       1100,1200,1300,1400,1500,1600,1700,1800,1900,1900,
     2       1900,2200,2300,2400,1900,2600,3300,3300,3300,3300,
     3       3300,3300,3300,3400,3500,3600,3700,3800,3900,4000) , i
C                                        . . . . . . . . . . seek
  200 CALL mnseek(fcn,futil)
      GO TO 5000
C                                        . . . . . . . . . . simplex
  300 CALL mnsimp(fcn,futil)
      IF (isw(4) .LT. 1)  ierflg = 4
      GO TO 5000
C                                        . . . . . . migrad, minimize
  400 CONTINUE
      nf = nfcn
      apsi = epsi
      CALL mnmigr(fcn,futil)
      CALL mnwerr
      IF (isw(4) .GE. 1)         GO TO 5000
        ierflg = 4
      IF (isw(1) .EQ. 1)         GO TO 5000
      IF (cword(1:3) .EQ. 'MIG') GO TO 5000
      nfcnmx = nfcnmx + nf - nfcn
      nf = nfcn
      CALL mnsimp(fcn,futil)
      IF (isw(1) .EQ. 1)  GO TO 5000
      nfcnmx = nfcnmx + nf - nfcn
      CALL mnmigr(fcn,futil)
         IF (isw(4) .GE. 1)  ierflg = 0
      CALL mnwerr
      GO TO 5000
C                                        . . . . . . . . . . minos
  500 CONTINUE
      nsuper = nfcn + 2*(npar+1)*nfcnmx
C          possible loop over new minima
      epsi = 0.1 * up
  510 CONTINUE
      CALL mncuve(fcn,futil)
      CALL mnmnos(fcn,futil)
      IF (.NOT. lnewmn)  GO TO 5000
      CALL mnrset(0)
      CALL mnmigr(fcn,futil)
      CALL mnwerr
      IF (nfcn .LT. nsuper)  GO TO 510
      WRITE (isyswr,'(/'' TOO MANY FUNCTION CALLS. MINOS GIVES UP''/)')
      ierflg = 4
      GO TO 5000
C                                        . . . . . . . . . .set, show
  700 CALL mnset(fcn,futil)
      GO TO 5000
C                                        . . . . . . . . . . top of page
  800 CONTINUE
      WRITE (isyswr,'(1H1)')
      GO TO 5000
C                                        . . . . . . . . . . fix
  900 ltofix = .true.
C                                        . . (also release) ....
  901 CONTINUE
      lfreed = .false.
      lfixed = .false.
      IF (llist .EQ. 0)  THEN
         WRITE (isyswr,'(A,A)') cword,':  NO PARAMETERS REQUESTED '
         GO TO 5000
      ENDIF
      DO 950 ilist= 1, llist
      iext = plist(ilist)
      chwhy = ' IS UNDEFINED.'
      IF (iext .LE. 0)         GO TO 930
      IF (iext .GT. nu)        GO TO 930
      IF (nvarl(iext) .LT. 0)  GO TO 930
      chwhy = ' IS CONSTANT.  '
      IF (nvarl(iext) .EQ. 0)  GO TO 930
      iint = niofex(iext)
      IF (ltofix) THEN
         chwhy = ' ALREADY FIXED.'
         IF (iint .EQ. 0)      GO TO 930
         CALL mnfixp(iint,ierr)
         IF (ierr .EQ. 0) THEN
            lfixed = .true.
         ELSE
            ierflg = 4
         ENDIF
      ELSE
         chwhy = ' ALREADY VARIABLE.'
         IF (iint .GT. 0)      GO TO 930
         krl = -iabs(iext)
         CALL mnfree(krl)
         lfreed = .true.
      ENDIF
      GO TO 950
  930 WRITE (isyswr,'(A,I4,A,A)') ' PARAMETER',iext,chwhy,' IGNORED.'
  950 CONTINUE
      IF (lfreed .OR. lfixed)  CALL mnrset(0)
      IF (lfreed)  THEN
          isw(2) = 0
          dcovar = 1.
          edm = bigedm
          isw(4) = 0
      ENDIF
      CALL mnwerr
      IF (isw(5) .GT. 1)  CALL mnprin(5,amin)
      GO TO 5000
C                                        . . . . . . . . . . restore
 1000 it = word7(1)
      IF (it.GT.1 .OR. it.LT.0)  GO TO 1005
      lfreed = (npfix .GT. 0)
      CALL mnfree(it)
      IF (lfreed) THEN
         CALL mnrset(0)
         isw(2) = 0
         dcovar = 1.
         edm = bigedm
      ENDIF
      GO TO 5000
 1005 WRITE (isyswr,'(A,I4)') ' IGNORED.  UNKNOWN ARGUMENT:',it
      ierflg = 3
      GO TO 5000
C                                        . . . . . . . . . . release
 1100 ltofix = .false.
      GO TO 901
C                                       . . . . . . . . . . scan . . .
 1200 CONTINUE
      iext = word7(1)
      IF (iext .LE. 0)  GO TO 1210
      it2 = 0
      IF (iext .LE. nu)  it2 = niofex(iext)
      IF (it2 .LE. 0)  GO TO 1250
 1210 CALL mnscan(fcn,futil)
      GO TO 5000
 1250 WRITE (isyswr,'(A,I4,A)') ' PARAMETER',iext,' NOT VARIABLE.'
      ierflg = 3
      GO TO 5000
C                                        . . . . . . . . . . contour
 1300 CONTINUE
      ke1 = word7(1)
      ke2 = word7(2)
      IF (ke1 .EQ. 0)  THEN
         IF (npar .EQ. 2)  THEN
            ke1 = nexofi(1)
            ke2 = nexofi(2)
         ELSE
            WRITE (isyswr,'(A,A)') cword,':  NO PARAMETERS REQUESTED '
            ierflg = 3
            GO TO 5000
         ENDIF
      ENDIF
      nfcnmx = 1000
      CALL mncntr(fcn,ke1,ke2,ierrf,futil)
      IF (ierrf .GT. 0)  ierflg = 3
      GO TO 5000
C                                        . . . . . . . . . . hesse
 1400 CONTINUE
      CALL mnhess(fcn,futil)
      CALL mnwerr
      IF (isw(5) .GE. 0)  CALL mnprin(2, amin)
      IF (isw(5) .GE. 1)  CALL mnmatu(1)
      GO TO 5000
C                                        . . . . . . . . . . save
 1500 CONTINUE
      CALL mnsave
      GO TO 5000
C                                        . . . . . . . . . . improve
 1600 CONTINUE
      CALL mncuve(fcn,futil)
      CALL mnimpr(fcn,futil)
      IF (lnewmn)  GO TO 400
      ierflg = 4
      GO TO 5000
C                                        . . . . . . . . . . call fcn
 1700 iflag = word7(1)
      nparx = npar
      f = undefi
      CALL fcn(nparx,gin,f,u,iflag,futil)
      nfcn = nfcn + 1
      nowprt = 0
      IF (f .NE. undefi)  THEN
         IF (amin .EQ. undefi)  THEN
             amin = f
             nowprt = 1
         ELSE IF (f .LT. amin)  THEN
             amin = f
             nowprt = 1
         ENDIF
         IF (isw(5).GE.0 .AND. iflag.LE.5 .AND. nowprt.EQ.1)
     +          CALL mnprin(5,amin)
         IF (iflag .EQ. 3)  fval3=f
      ENDIF
      IF (iflag .GT. 5)  CALL mnrset(1)
      GO TO 5000
C                                        . . . . . . . . . . standard
 1800 CALL stand
      GO TO 5000
C                                       . . . return, stop, end, exit
 1900 it = word7(1)
      IF (fval3 .NE. amin .AND. it .EQ. 0)  THEN
        iflag = 3
        IF (isw(5) .GE. 0)
     +WRITE (isyswr,'(/A/)') ' CALL TO USER FUNCTION WITH IFLAG = 3'
        nparx = npar
        CALL fcn(nparx,gin,f,u,iflag,futil)
        nfcn = nfcn + 1
        fval3 = f
      ENDIF
      ierflg = 11
      IF (cword(1:3) .EQ. 'END')  ierflg = 10
      IF (cword(1:3) .EQ. 'RET')  ierflg = 12
      GO TO 5000
C                                        . . . . . . . . . . clear
 2200 CONTINUE
      CALL mncler
      IF (isw(5) .GE. 1)  WRITE (isyswr,'(A)')
     + ' MINUIT MEMORY CLEARED. NO PARAMETERS NOW DEFINED.'
      GO TO 5000
C                                        . . . . . . . . . . help
 2300 CONTINUE
CCCC      IF (INDEX(CWORD,'SHO') .GT. 0)  GO TO 700
CCCC      IF (INDEX(CWORD,'SET') .GT. 0)  GO TO 700
      kcol = 0
      DO 2310 icol= 5,lk
        IF (cword(icol:icol) .EQ. ' ') GO TO 2310
        kcol = icol
        GO TO 2320
 2310 CONTINUE
 2320 CONTINUE
      IF (kcol .EQ. 0)  THEN
         comd = '*   '
      ELSE
         comd = cword(kcol:lk)
      ENDIF
      CALL mnhelp(comd,isyswr)
      GO TO 5000
C                                       . . . . . . . . . . MNContour
 2400 CONTINUE
      epsi = 0.05 * up
      ke1 = word7(1)
      ke2 = word7(2)
      IF (ke1.EQ.0 .AND. npar.EQ.2) THEN
         ke1 = nexofi(1)
         ke2 = nexofi(2)
         ENDIF
      nptu = word7(3)
      IF (nptu .LE. 0)  nptu=20
      IF (nptu .GT. mxpt)  nptu = mxpt
      nfcnmx =  100*(nptu+5)*(npar+1)
      CALL mncont(fcn,ke1,ke2,nptu,xptu,yptu,ierrf,futil)
      IF (ierrf .LT. nptu) ierflg = 4
      IF (ierrf .EQ. -1)   ierflg = 3
      GO TO 5000
C                                      . . . . . . . . . . jump
 2600 CONTINUE
      step = word7(1)
      IF (step .LE. zero)  step = 2.
      rno = 0.
      izero = 0
      DO 2620 i= 1, npar
        CALL mnrn15(rno,izero)
        rno = 2.0*rno - 1.0
 2620   x(i) = x(i) + rno*step*werr(i)
      CALL mninex(x)
      CALL mnamin(fcn,futil)
      CALL mnrset(0)
      GO TO 5000
C                                      . . . . . . . . . . blank line
 3300 CONTINUE
      WRITE (isyswr,'(10X,A)') ' BLANK COMMAND IGNORED.'
      ierflg = 1
      GO TO 5000
C  . . . . . . . . obsolete commands     . . . . . . . . . . . . . .
C                                      . . . . . . . . . . covariance
 3400 CONTINUE
      WRITE (isyswr, '(A)') ' THE "COVARIANCE" COMMAND IS OSBSOLETE.',
     + ' THE COVARIANCE MATRIX IS NOW SAVED IN A DIFFERENT FORMAT',
     + ' WITH THE "SAVE" COMMAND AND READ IN WITH:"SET COVARIANCE"'
      ierflg = 3
      GO TO 5000
C                                        . . . . . . . . . . printout
 3500 CONTINUE
      cneway = 'SET PRInt '
      GO TO 3100
C                                        . . . . . . . . . . gradient
 3600 CONTINUE
      cneway = 'SET GRAd  '
      GO TO 3100
C                                        . . . . . . . . . . matout
 3700 CONTINUE
      cneway = 'SHOW COVar'
      GO TO 3100
C                                        . . . . . . . . . error def
 3800 CONTINUE
      cneway = 'SET ERRdef'
      GO TO 3100
C                                        . . . . . . . . . . limits
 3900 CONTINUE
      cneway = 'SET LIMits'
      GO TO 3100
C                                        . . . . . . . . . . punch
 4000 CONTINUE
      cneway = 'SAVE      '
C                                ....... come from obsolete commands
 3100 WRITE (isyswr, 3101) cword,cneway
 3101 FORMAT (' OBSOLETE COMMAND:',1x,a10,5x,'PLEASE USE:',1x,a10)
      cword = cneway
      IF (cword .EQ. 'SAVE      ') GO TO 1500
      GO TO 700
C                                 . . . . . . . . . . . . . . . . . .
 5000 RETURN
      END