cdeck id>, minuit. subroutine minuit(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) 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 c c cpnam parameter name (10 characters) c u external (visible to user in fcn) value of parameter c alim, blim lower and upper parameter limits. if both zero, no limits. c erp,ern positive and negative minos errors, if calculated. c werr external parameter error (standard deviation, defined by up) c globcc global correlation coefficient c nvarl =-1 if parameter undefined, =0 if constant, c = 1 if variable without limits, =4 if variable with limits c (note that if parameter has been fixed, nvarl=1 or =4, and niofex=0) c niofex internal parameter number, or zero if not currently variable c nexofi external parameter number for currently variable parameters c x, xt internal parameter values (x are sometimes saved in xt) c dirin (internal) step sizes for current step c variables with names ending in ..s are saved values for fixed params c vhmat (internal) error matrix stored as half matrix, since c it is symmetric c vthmat vhmat is sometimes saved in vthmat, especially in mnmnot c c isw definitions: c isw(1) =0 normally, =1 means call limit exceeded c isw(2) =0 means no error matrix c =1 means only approximate error matrix c =2 means full error matrix, but forced pos-def. c =3 means good normal full error matrix exists c isw(3) =0 if minuit is calculating the first derivatives c =1 if first derivatives calculated inside fcn c isw(4) =-1 if most recent minimization did not converge. c = 0 if problem redefined since most recent minimization. c =+1 if most recent minimization did converge. c isw(5) is the print level. see sho printlevel c isw(6) = 0 for batch mode, =1 for interactive mode c c lwarn is true if warning messges are to be put out (default=true) c set warn turns it on, set nowarn turns it off c lrepor is true if exceptional conditions are put out (default=false) c set debug turns it on, set nodebug turns it off c limset is true if a parameter is up against limits (for minos) c lnolim is true if there are no limits on any parameters (not yet used) c lnewmn is true if the previous process has unexpectedly improved fcn c lphead is true if a heading should be put out for the next parameter c definition, false if a parameter has just been defined c external fcn,futil character*40 cwhyxt data cwhyxt/'for unknown reasons '/ data jsysrd,jsyswr,jsyssa/5,6,7/ c . . . . . . . . . . initialize minuit write (jsyswr,'(1x,75(1h*))') call mninit (jsysrd,jsyswr,jsyssa) c . . . . initialize new data block 100 continue write (isyswr,'(1x,75(1h*))') nblock = nblock + 1 write (isyswr,'(26x,a,i4)') 'minuit data block no.',nblock write (isyswr,'(1x,75(1h*))') c . . . . . . . . . . . set parameter lists to undefined call mncler c . . . . . . . . read title call mnread(fcn,1,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 c . . . . . . . . read parameters call mnread(fcn,2,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 if (iflgut .eq. 4) go to 700 c . . . . . . verify fcn not time-dependent write (isyswr,'(/a,a)') ' minuit: first call to user function,', + ' with iflag=1' nparx = npar call mninex(x) fzero = undefi call fcn(nparx,gin,fzero,u,1,futil) first = undefi call fcn(nparx,gin,first,u,4,futil) nfcn = 2 if (fzero.eq.undefi .and. first.eq.undefi) then cwhyxt = 'by error in user function. ' write (isyswr,'(/a,a/)') ' user has not calculated function', + ' value when iflag=1 or 4' go to 800 endif amin = first if (first .eq. undefi) amin=fzero call mnprin(1,amin) nfcn = 2 if (first .eq. fzero) go to 300 fnew = 0.0 call fcn(nparx,gin,fnew,u,4,futil) if (fnew .ne. amin) write (isyswr,280) amin, fnew 280 format (/' minuit warning: probable error in user function.'/ + ' for fixed values of parameters, fcn is time-dependent'/ + ' f =',e22.14,' for first call'/ + ' f =',e22.14,' for second call.'/) nfcn = 3 300 fval3 = 2.0*amin+1.0 c . . . . . . . . . . . read commands call mnread(fcn,3,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 if (iflgut .eq. 4) go to 700 cwhyxt = 'by minuit command: '//cword if (index(cword,'stop').gt. 0) go to 800 if (index(cword,'exi') .gt. 0) go to 800 if (index(cword,'ret') .eq. 0) go to 100 cwhyxt = 'and returns to user program. ' write (isyswr,'(a,a)') ' ..........minuit terminated ',cwhyxt return c . . . . . . stop conditions 500 continue cwhyxt = 'by end-of-data on primary input file. ' go to 800 600 continue cwhyxt = 'by unrecoverable read error on input. ' go to 800 700 continue cwhyxt = ': fatal error in parameter definitions. ' 800 write (isyswr,'(a,a)') ' ..........minuit terminated ',cwhyxt stop c c ......................entry to set unit numbers - - - - - - - - - - entry mintio(i1,i2,i3) jsysrd = i1 jsyswr = i2 jsyssa = i3 return end cdeck id>, mnamin. subroutine mnamin(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from many places. initializes the value of amin by cc calling the user function. prints out the function value and cc parameter values if print flag value is high enough. cc 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 nparx = npar if (isw(5) .ge. 1) write (isyswr,'(/a,a)') ' first call to ', + 'user function at new start point, with iflag=4.' call mnexin(x) call fcn(nparx,gin,fnew,u,4,futil) nfcn = nfcn + 1 amin = fnew edm = bigedm return end cdeck id>, mnbins. subroutine mnbins(a1,a2,naa,bl,bh,nb,bwid) c ************ double precision version ************* implicit double precision (a-h,o-z) c subroutine to determine reasonable histogram intervals c given absolute upper and lower bounds a1 and a2 c and desired maximum number of bins naa c program makes reasonable binning from bl to bh of width bwid c f. james, august, 1974 , stolen for minuit, 1988 parameter (zero=0.0) al = min(a1,a2) ah = max(a1,a2) if (al.eq.ah) ah = al + 1. c if naa .eq. -1 , program uses bwid input from calling routine if (naa .eq. -1) go to 150 10 na = naa - 1 if (na .lt. 1) na = 1 c get nominal bin width in expon form 20 awid = (ah-al)/float(na) log = int(log10(awid)) if (awid .le. 1.0) log=log-1 sigfig = awid * (10.00 **(-log)) c round mantissa up to 2, 2.5, 5, or 10 if(sigfig .gt. 2.0) go to 40 sigrnd = 2.0 go to 100 40 if (sigfig .gt. 2.5) go to 50 sigrnd = 2.5 go to 100 50 if(sigfig .gt. 5.0) go to 60 sigrnd =5.0 go to 100 60 sigrnd = 1.0 log = log + 1 100 continue bwid = sigrnd*10.0**log go to 200 c get new bounds from new width bwid 150 if (bwid .le. zero) go to 10 200 continue alb = al/bwid lwid=alb if (alb .lt. zero) lwid=lwid-1 bl = bwid*float(lwid) alb = ah/bwid + 1.0 kwid = alb if (alb .lt. zero) kwid=kwid-1 bh = bwid*float(kwid) nb = kwid-lwid if (naa .gt. 5) go to 240 if (naa .eq. -1) return c request for one bin is difficult case if (naa .gt. 1 .or. nb .eq. 1) return bwid = bwid*2.0 nb = 1 return 240 if (2*nb .ne. naa) return na = na + 1 go to 20 end cdeck id>, mncalf. subroutine mncalf(fcn,pvec,ycalf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called only from mnimpr. transforms the function fcn cc by dividing out the quadratic part in order to find further cc minima. calculates ycalf = (f-fmin)/(x-xmin)*v*(x-xmin) cc 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 dimension pvec(15) nparx = npar call mninex(pvec) call fcn(nparx,gin,f,u,4,futil) nfcn = nfcn + 1 do 200 i= 1, npar grd(i) = 0. do 200 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n 200 grd(i) = grd(i) + vthmat(ndex) * (xt(j)-pvec(j)) denom = 0. do 210 i= 1, npar 210 denom = denom + grd(i) * (xt(i)-pvec(i)) if (denom .le. zero) then dcovar = 1. isw(2) = 0 denom = 1.0 endif ycalf = (f-apsi) / denom return end cdeck id>, mncler. subroutine mncler c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from minuit and by option from mnexcm cc resets the parameter list to undefined 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 npfix = 0 nu = 0 npar = 0 nfcn = 0 nwrmes(1) = 0 nwrmes(2) = 0 do 10 i= 1, maxext u(i) = 0.0 cpnam(i) = cundef nvarl(i) = -1 10 niofex(i) = 0 call mnrset(1) cfrom = 'clear ' nfcnfr = nfcn cstatu ='undefined ' lnolim = .true. lphead = .true. return end cdeck id>, mncntr. subroutine mncntr(fcn,ke1,ke2,ierrf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc to print function contours in two variables, on line printer cc 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 parameter (numbcs=20,nxmax=115) dimension contur(numbcs), fcna(nxmax),fcnb(nxmax) character clabel*(numbcs) character chln*(nxmax),chmid*(nxmax),chzero*(nxmax) data clabel/'0123456789abcdefghij'/ c input arguments: parx, pary, devs, ngrid if (ke1.le.0 .or. ke2.le.0) go to 1350 if (ke1.gt.nu .or. ke2.gt.nu) go to 1350 ki1 = niofex(ke1) ki2 = niofex(ke2) if (ki1.le.0 .or. ki2.le.0) go to 1350 if (ki1 .eq. ki2) go to 1350 c if (isw(2) .lt. 1) then call mnhess(fcn,futil) call mnwerr endif nparx = npar xsav = u(ke1) ysav = u(ke2) devs = word7(3) if (devs .le. zero) devs=2. xlo = u(ke1) - devs*werr(ki1) xup = u(ke1) + devs*werr(ki1) ylo = u(ke2) - devs*werr(ki2) yup = u(ke2) + devs*werr(ki2) ngrid = word7(4) if (ngrid .le. 0) then ngrid=25 nx = min(npagwd-15,ngrid) ny = min(npagln-7, ngrid) else nx = ngrid ny = ngrid endif if (nx .lt. 11) nx=11 if (ny .lt. 11) ny=11 if (nx .ge. nxmax) nx=nxmax-1 c ask if parameter outside limits if (nvarl(ke1) .gt. 1) then if (xlo .lt. alim(ke1)) xlo = alim(ke1) if (xup .gt. blim(ke1)) xup = blim(ke1) endif if (nvarl(ke2) .gt. 1) then if (ylo .lt. alim(ke2)) ylo = alim(ke2) if (yup .gt. blim(ke2)) yup = blim(ke2) endif bwidx = (xup-xlo)/real(nx) bwidy = (yup-ylo)/real(ny) ixmid = int((xsav-xlo)*real(nx)/(xup-xlo)) + 1 if (amin .eq. undefi) call mnamin(fcn,futil) do 185 i= 1, numbcs contur(i) = amin + up*float(i-1)**2 185 continue contur(1) = contur(1) + 0.01*up c fill fcnb to prepare first row, and find column zero u(ke2) = yup ixzero = 0 xb4 = one do 200 ix= 1, nx+1 u(ke1) = xlo + real(ix-1)*bwidx call fcn(nparx,gin,ff,u,4,futil) fcnb(ix) = ff if (xb4.lt.zero .and. u(ke1).gt.zero) ixzero = ix-1 xb4 = u(ke1) chmid(ix:ix) = '*' chzero(ix:ix)= '-' 200 continue write (isyswr,'(a,i3,a,a)') ' y-axis: parameter ', + ke2,': ',cpnam(ke2) if (ixzero .gt. 0) then chzero(ixzero:ixzero) = '+' chln = ' ' write (isyswr,'(12x,a,a)') chln(1:ixzero),'x=0' endif c loop over rows do 280 iy= 1, ny unext = u(ke2) - bwidy c prepare this line's background pattern for contour chln = ' ' chln(ixmid:ixmid) = '*' if (ixzero .ne. 0) chln(ixzero:ixzero) = ':' if (u(ke2).gt.ysav .and. unext.lt.ysav) chln=chmid if (u(ke2).gt.zero .and. unext.lt.zero) chln=chzero u(ke2) = unext ylabel = u(ke2) + 0.5*bwidy c move fcnb to fcna and fill fcnb with next row do 220 ix= 1, nx+1 fcna(ix) = fcnb(ix) u(ke1) = xlo + real(ix-1)*bwidx call fcn(nparx,gin,ff,u,4,futil) fcnb(ix) = ff 220 continue c look for contours crossing the fcnxy squares do 250 ix= 1, nx fmx = max(fcna(ix),fcnb(ix),fcna(ix+1),fcnb(ix+1)) fmn = min(fcna(ix),fcnb(ix),fcna(ix+1),fcnb(ix+1)) do 230 ics= 1, numbcs if (contur(ics) .gt. fmn) go to 240 230 continue go to 250 240 if (contur(ics) .lt. fmx) chln(ix:ix)=clabel(ics:ics) 250 continue c print a row of the contour plot write (isyswr,'(1x,g12.4,1x,a)') ylabel,chln(1:nx) 280 continue c contours printed, label x-axis chln = ' ' chln( 1: 1) = 'i' chln(ixmid:ixmid) = 'i' chln(nx:nx) = 'i' write (isyswr,'(14x,a)') chln(1:nx) c the hardest of all: print x-axis scale! chln = ' ' if (nx .le. 26) then nl = max(nx-12,2) nl2 = nl/2 write (isyswr,'(8x,g12.4,a,g12.4)') xlo,chln(1:nl),xup write (isyswr,'(14x,a,g12.4)') chln(1:nl2),xsav else nl = max(nx-24,2)/2 nl2 = nl if (nl .gt. 10) nl2=nl-6 write (isyswr,'(8x,g12.4,a,g12.4,a,g12.4)') xlo, + chln(1:nl),xsav,chln(1:nl2),xup endif write (isyswr,'(6x,a,i3,a,a,a,g12.4)') ' x-axis: parameter', + ke1,': ',cpnam(ke1),' one column=',bwidx write (isyswr,'(a,g12.4,a,g12.4,a)') ' function values: f(i)=', + amin,' +',up,' *i**2' c finished. reset input values u(ke1) = xsav u(ke2) = ysav ierrf = 0 return 1350 write (isyswr,1351) 1351 format (' invalid parameter number(s) requested. ignored.' /) ierrf = 1 return end cdeck id>, mncont. subroutine mncont(fcn,ke1,ke2,nptu,xptu,yptu,ierrf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc find nptu points along a contour where the function cc fmin (x(ke1),x(ke2)) = amin+up cc where fmin is the minimum of fcn with respect to all cc the other npar-2 variable parameters (if any). cc ierrf on return will be equal to the number of points found: cc nptu if normal termination with nptu points found cc -1 if errors in the calling sequence (ke1, ke2 not variable) cc 0 if less than four points can be found (using mnmnot) cc n>3 if only n points can be found (n < nptu) cc 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 dimension xptu(nptu), yptu(nptu), w(mni),gcc(mni) character chere*10 parameter (chere='mncontour ') logical ldebug external fcn,futil c input arguments: parx, pary, devs, ngrid ldebug = (idbg(6) .ge. 1) if (ke1.le.0 .or. ke2.le.0) go to 1350 if (ke1.gt.nu .or. ke2.gt.nu) go to 1350 ki1 = niofex(ke1) ki2 = niofex(ke2) if (ki1.le.0 .or. ki2.le.0) go to 1350 if (ki1 .eq. ki2) go to 1350 if (nptu .lt. 4) go to 1400 c nfcnco = nfcn nfcnmx = 100*(nptu+5)*(npar+1) c the minimum call mncuve(fcn,futil) u1min = u(ke1) u2min = u(ke2) ierrf = 0 cfrom = chere nfcnfr = nfcnco if (isw(5) .ge. 0) then write (isyswr,'(1x,a,i4,a)') + 'start mncontour calculation of',nptu,' points on contour.' if (npar .gt. 2) then if (npar .eq. 3) then ki3 = 6 - ki1 - ki2 ke3 = nexofi(ki3) write (isyswr,'(1x,a,i3,2x,a)') + 'each point is a minimum with respect to parameter ', + ke3, cpnam(ke3) else write (isyswr,'(1x,a,i3,a)') + 'each point is a minimum with respect to the other', + npar-2, ' variable parameters.' endif endif endif c c find the first four points using mnmnot c ........................ first two points call mnmnot(fcn,ke1,ke2,val2pl,val2mi,futil) if (ern(ki1) .eq. undefi) then xptu(1) = alim(ke1) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (ern(ki1) .ge. zero) go to 1500 xptu(1) = u1min+ern(ki1) endif yptu(1) = val2mi c if (erp(ki1) .eq. undefi) then xptu(3) = blim(ke1) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (erp(ki1) .le. zero) go to 1500 xptu(3) = u1min+erp(ki1) endif yptu(3) = val2pl scalx = 1.0/(xptu(3) - xptu(1)) c ........................... next two points call mnmnot(fcn,ke2,ke1,val2pl,val2mi,futil) if (ern(ki2) .eq. undefi) then yptu(2) = alim(ke2) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (ern(ki2) .ge. zero) go to 1500 yptu(2) = u2min+ern(ki2) endif xptu(2) = val2mi if (erp(ki2) .eq. undefi) then yptu(4) = blim(ke2) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (erp(ki2) .le. zero) go to 1500 yptu(4) = u2min+erp(ki2) endif xptu(4) = val2pl scaly = 1.0/(yptu(4) - yptu(2)) nowpts = 4 next = 5 if (ldebug) then write (isyswr,'(a)') ' plot of four points found by minos' xpt(1) = u1min ypt(1) = u2min chpt(1) = ' ' nall = min(nowpts+1,maxcpt) do 85 i= 2, nall xpt(i) = xptu(i-1) ypt(i) = yptu(i-1) 85 continue chpt(2)= 'a' chpt(3)= 'b' chpt(4)= 'c' chpt(5)= 'd' call mnplot(xpt,ypt,chpt,nall,isyswr,npagwd,npagln) endif c c ..................... save some values before fixing isw2 = isw(2) isw4 = isw(4) sigsav = edm istrav = istrat dc = dcovar apsi = epsi*0.5 abest=amin mpar=npar nfmxin = nfcnmx do 125 i= 1, mpar 125 xt(i) = x(i) do 130 j= 1, mpar*(mpar+1)/2 130 vthmat(j) = vhmat(j) do 135 i= 1, mpar gcc(i) = globcc(i) 135 w(i) = werr(i) c fix the two parameters in question kints = niofex(ke1) call mnfixp (kints,ierr) kints = niofex(ke2) call mnfixp (kints,ierr) c ......................fill in the rest of the points do 900 inew= next, nptu c find the two neighbouring points with largest separation bigdis = 0. do 200 iold = 1, inew-1 i2 = iold + 1 if (i2 .eq. inew) i2 = 1 dist = (scalx*(xptu(iold)-xptu(i2)))**2 + + (scaly*(yptu(iold)-yptu(i2)))**2 if (dist .gt. bigdis) then bigdis = dist idist = iold endif 200 continue i1 = idist i2 = i1 + 1 if (i2 .eq. inew) i2 = 1 c next point goes between i1 and i2 a1 = half a2 = half 300 xmidcr = a1*xptu(i1) + a2*xptu(i2) ymidcr = a1*yptu(i1) + a2*yptu(i2) xdir = yptu(i2) - yptu(i1) ydir = xptu(i1) - xptu(i2) sclfac = max(abs(xdir*scalx), abs(ydir*scaly)) xdircr = xdir/sclfac ydircr = ydir/sclfac ke1cr = ke1 ke2cr = ke2 c find the contour crossing point along dir amin = abest call mncros(fcn,aopt,iercr,futil) if (iercr .gt. 1) then c if cannot find mid-point, try closer to point 1 if (a1 .gt. half) then write (isyswr,'(a,a,i3,a)') ' mncont cannot find next', + ' point on contour. only ',nowpts,' points found.' go to 950 endif call mnwarn('w',chere,'cannot find midpoint, try closer.') a1 = 0.75 a2 = 0.25 go to 300 endif c contour has been located, insert new point in list do 830 move= nowpts,i1+1,-1 xptu(move+1) = xptu(move) yptu(move+1) = yptu(move) 830 continue nowpts = nowpts + 1 xptu(i1+1) = xmidcr + xdircr*aopt yptu(i1+1) = ymidcr + ydircr*aopt 900 continue 950 continue c ierrf = nowpts cstatu = 'successful' if (nowpts .lt. nptu) cstatu = 'incomplete' c make a lineprinter plot of the contour if (isw(5) .ge. 0) then xpt(1) = u1min ypt(1) = u2min chpt(1) = ' ' nall = min(nowpts+1,maxcpt) do 1000 i= 2, nall xpt(i) = xptu(i-1) ypt(i) = yptu(i-1) chpt(i)= 'x' 1000 continue write (isyswr,'(a,i3,2x,a)') ' y-axis: parameter ',ke2, + cpnam(ke2) call mnplot(xpt,ypt,chpt,nall,isyswr,npagwd,npagln) write (isyswr,'(25x,a,i3,2x,a)') 'x-axis: parameter ', + ke1,cpnam(ke1) endif c print out the coordinates around the contour if (isw(5) .ge. 1) then npcol = (nowpts+1)/2 nfcol = nowpts/2 write (isyswr,'(/i5,a,g13.5,a,g11.3)') nowpts, + ' points on contour. fmin=',abest,' errdef=',up write (isyswr,'(9x,a,3x,a,18x,a,3x,a)') + cpnam(ke1),cpnam(ke2),cpnam(ke1),cpnam(ke2) do 1050 line = 1, nfcol lr = line + npcol write (isyswr,'(1x,i5,2g13.5,10x,i5,2g13.5)') + line,xptu(line),yptu(line),lr,xptu(lr),yptu(lr) 1050 continue if (nfcol .lt. npcol) write (isyswr,'(1x,i5,2g13.5)') + npcol,xptu(npcol),yptu(npcol) endif c . . contour finished. reset v itaur = 1 call mnfree(1) call mnfree(1) do 1100 j= 1, mpar*(mpar+1)/2 1100 vhmat(j) = vthmat(j) do 1120 i= 1, mpar globcc(i) = gcc(i) werr(i) = w(i) 1120 x(i) = xt(i) call mninex (x) edm = sigsav amin = abest isw(2) = isw2 isw(4) = isw4 dcovar = dc itaur = 0 nfcnmx = nfmxin istrat = istrav u(ke1) = u1min u(ke2) = u2min go to 2000 c error returns 1350 write (isyswr,'(a)') ' invalid parameter numbers.' go to 1450 1400 write (isyswr,'(a)') ' less than four points requested.' 1450 ierrf = -1 cstatu = 'user error' go to 2000 1500 write (isyswr,'(a)') ' mncont unable to find four points.' u(ke1) = u1min u(ke2) = u2min ierrf = 0 cstatu = 'failed' 2000 continue cfrom = chere nfcnfr = nfcnco return end cdeck id>, mncrck. subroutine mncrck(crdbuf,maxcwd,comand,lnc, + mxp, plist, llist,ierr,isyswr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc cc called from mnread. cc cracks the free-format input, expecting zero or more cc alphanumeric fields (which it joins into comand(1:lnc)) cc followed by one or more numeric fields separated by cc blanks and/or one comma. the numeric fields are put into cc the llist (but at most mxp) elements of plist. cc ierr = 0 if no errors, cc = 1 if error(s). cc diagnostic messages are written to isyswr cc parameter (maxelm=25, mxlnel=19) character*(*) comand, crdbuf character cnumer*13, celmnt(maxelm)*(mxlnel), cnull*15 dimension lelmnt(maxelm),plist(mxp) data cnull /')null string '/ data cnumer/'123456789-.0+'/ ielmnt = 0 lend = len(crdbuf) nextb = 1 ierr = 0 c . . . . loop over words celmnt 10 continue do 100 ipos= nextb,lend ibegin = ipos if (crdbuf(ipos:ipos).eq.' ') go to 100 if (crdbuf(ipos:ipos).eq.',') go to 250 go to 150 100 continue go to 300 150 continue c found beginning of word, look for end do 180 ipos = ibegin+1,lend if (crdbuf(ipos:ipos).eq.' ') go to 250 if (crdbuf(ipos:ipos).eq.',') go to 250 180 continue ipos = lend+1 250 iend = ipos-1 ielmnt = ielmnt + 1 if (iend .ge. ibegin) then celmnt(ielmnt) = crdbuf(ibegin:iend) else celmnt(ielmnt) = cnull endif lelmnt(ielmnt) = iend-ibegin+1 if (lelmnt(ielmnt) .gt. mxlnel) then write (isyswr, 253) crdbuf(ibegin:iend),celmnt(ielmnt) 253 format (' minuit warning: input data word too long.' + /' original:',a + /' truncated to:',a) lelmnt(ielmnt) = mxlnel endif if (ipos .ge. lend) go to 300 if (ielmnt .ge. maxelm) go to 300 c look for comma or beginning of next word do 280 ipos= iend+1,lend if (crdbuf(ipos:ipos) .eq. ' ') go to 280 nextb = ipos if (crdbuf(ipos:ipos) .eq. ',') nextb = ipos+1 go to 10 280 continue c all elements found, join the alphabetic ones to c form a command 300 continue nelmnt = ielmnt comand = ' ' lnc = 1 plist(1) = 0. llist = 0 if (ielmnt .eq. 0) go to 900 kcmnd = 0 do 400 ielmnt = 1, nelmnt if (celmnt(ielmnt) .eq. cnull) go to 450 do 350 ic= 1, 13 if (celmnt(ielmnt)(1:1) .eq. cnumer(ic:ic)) go to 450 350 continue if (kcmnd .ge. maxcwd) go to 400 left = maxcwd-kcmnd ltoadd = lelmnt(ielmnt) if (ltoadd .gt. left) ltoadd=left comand(kcmnd+1:kcmnd+ltoadd) = celmnt(ielmnt)(1:ltoadd) kcmnd = kcmnd + ltoadd if (kcmnd .eq. maxcwd) go to 400 kcmnd = kcmnd + 1 comand(kcmnd:kcmnd) = ' ' 400 continue lnc = kcmnd go to 900 450 continue lnc = kcmnd c . . . . we have come to a numeric field llist = 0 do 600 ifld= ielmnt,nelmnt llist = llist + 1 if (llist .gt. mxp) then nreq = nelmnt-ielmnt+1 write (isyswr,511) nreq,mxp 511 format (/' minuit warning in mncrck: '/ ' command has input',i5, + ' numeric fields, but minuit can accept only',i3) go to 900 endif if (celmnt(ifld) .eq. cnull) then plist(llist) = 0. else read (celmnt(ifld), '(bn,f19.0)',err=575) plist(llist) endif go to 600 575 write (isyswr,'(a,a,a)') ' format error in numeric field: "', + celmnt(ifld)(1:lelmnt(ifld)),'"' ierr = 1 plist(llist) = 0. 600 continue c end loop over numeric fields 900 continue if (lnc .le. 0) lnc=1 return end cdeck id>, mncros. subroutine mncros(fcn,aopt,iercr,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc find point where mneval=amin+up, along the line through cc xmid,ymid with direction xdir,ydir, where x and y are cc parameters ke1 and ke2. if ke2=0 (from minos), then cc only ke1 is varied. from mncont, both are varied. cc crossing point is at cc (u(ke1),u(ke2)) = (xmid,ymid) + aopt*(xdir,ydir) cc 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 character chere*10, charal*28, chsign*4 parameter (chere='mncontour ', mlsb=3, maxitr=15, tlr=0.01) dimension flsb(mlsb),alsb(mlsb), coeff(3) logical ldebug external fcn,futil data charal/' .abcdefghijklmnopqrstuvwxyz'/ ldebug = (idbg(6) .ge. 1) aminsv = amin aim = amin + up tlf = tlr*up tla = tlr*0.1 xpt(1) = 0.0 ypt(1) = aim chpt(1) = ' ' xpt(2) = -1.0 ypt(2) = amin chpt(2) = '.' ipt = 2 c find the largest allowed a aulim = 100. do 100 ik= 1, 2 if (ik .eq. 1) then kex = ke1cr zmid = xmidcr zdir = xdircr else if (ke2cr .eq. 0) go to 100 kex = ke2cr zmid = ymidcr zdir = ydircr endif if (nvarl(kex) .le. 1) go to 100 if (zdir .eq. zero) go to 100 zlim = alim(kex) if (zdir .gt. zero) zlim = blim(kex) aulim = min(aulim,(zlim-zmid)/zdir) 100 continue c lsb = line search buffer c first point anext = 0. aopt = anext limset = .false. if (aulim .lt. aopt+tla) limset = .true. call mneval(fcn,anext,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 ipt = ipt + 1 xpt(ipt) = anext ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) alsb(1) = anext flsb(1) = fnext fnext = max(fnext,aminsv+0.1*up) aopt = dsqrt((up)/(fnext-aminsv)) - 1.0 if (abs(fnext-aim) .lt. tlf) go to 800 c if (aopt .lt. -0.5) aopt = -0.5 limset = .false. if (aopt .gt. aulim) then aopt = aulim limset = .true. endif call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 alsb(2) = aopt ipt = ipt + 1 xpt(ipt) = alsb(2) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(2) = fnext dfda = (flsb(2)-flsb(1))/ (alsb(2)-alsb(1)) ilsb = 2 c dfda must be positive on the contour if (dfda .gt. zero) go to 460 300 call mnwarn('d',chere,'looking for slope of the right sign') maxlk = maxitr - ipt do 400 it= 1, maxlk alsb(1) = alsb(2) flsb(1) = flsb(2) aopt = alsb(1) + 0.2*real(it) limset = .false. if (aopt .gt. aulim) then aopt = aulim limset = .true. endif call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 alsb(2) = aopt ipt = ipt + 1 xpt(ipt) = alsb(2) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(2) = fnext dfda = (flsb(2)-flsb(1))/ (alsb(2)-alsb(1)) if (dfda .gt. zero) go to 450 400 continue call mnwarn('w',chere,'cannot find slope of the right sign') go to 950 450 continue c we have two points with the right slope 460 aopt = alsb(2) + (aim-flsb(2))/dfda if (min(abs(aopt-alsb(1)),abs(aopt-alsb(2))).lt. tla) go to 800 if (ipt .ge. maxitr) go to 950 bmin = min(alsb(1),alsb(2)) - 1.0 if (aopt .lt. bmin) aopt = bmin bmax = max(alsb(1),alsb(2)) + 1.0 if (aopt .gt. bmax) aopt = bmax c try a third point call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 alsb(3) = aopt ipt = ipt + 1 xpt(ipt) = alsb(3) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(3) = fnext inew = 3 c now we have three points, ask how many , mncuve. subroutine mncuve(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc makes sure that the current point is a local cc minimum and that the error matrix exists, cc or at least something good enough for minos and mncont cc 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 if (isw(4) .lt. 1) then write (isyswr,'(/a,a)') + ' function must be minimized before calling ',cfrom apsi = epsi call mnmigr(fcn,futil) endif if (isw(2) .lt. 3) then call mnhess(fcn,futil) if (isw(2) .lt. 1) then call mnwarn('w',cfrom,'no error matrix. will improvise.') do 555 i=1,npar ndex = i*(i-1)/2 do 554 j=1,i-1 ndex = ndex + 1 554 vhmat(ndex) = 0. ndex = ndex + 1 if (g2(i) .le. zero) then wint = werr(i) iext = nexofi(i) if (nvarl(iext) .gt. 1) then call mndxdi(x(i),i,dxdi) if (abs(dxdi) .lt. .001) then wint = .01 else wint = wint/abs(dxdi) endif endif g2(i) = up/wint**2 endif vhmat(ndex) = 2./g2(i) 555 continue isw(2) = 1 dcovar = 1. else call mnwerr endif endif return end cdeck id>, mnderi. subroutine mnderi(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the first derivatives of fcn (grd), cc either by finite differences or by transforming the user- cc supplied derivatives to internal coordinates, cc according to whether isw(3) is zero or one. cc 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 logical ldebug character cbf1*22 nparx = npar ldebug = (idbg(2) .ge. 1) if (amin .eq. undefi) call mnamin(fcn,futil) if (isw(3) .eq. 1) go to 100 if (ldebug) then c make sure starting at the right place call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 if (fs1 .ne. amin) then df = amin - fs1 write (cbf1(1:12),'(g12.3)') df call mnwarn('d','mnderi', + 'function value differs from amin by '//cbf1(1:12) ) amin = fs1 endif write + (isyswr,'(/'' first derivative debug printout. mnderi''/ + '' par deriv step minstep optstep '', + '' d1-d2 2nd drv'')') endif dfmin = 8. * epsma2*(abs(amin)+up) if (istrat .le. 0) then ncyc = 2 tlrstp = 0.5 tlrgrd = 0.1 else if (istrat .eq. 1) then ncyc = 3 tlrstp = 0.3 tlrgrd = 0.05 else ncyc = 5 tlrstp = 0.1 tlrgrd = 0.02 endif c loop over variable parameters do 60 i=1,npar epspri = epsma2 + abs(grd(i)*epsma2) c two-point derivatives always assumed necessary c maximum number of cycles over step size depends on strategy xtf = x(i) stepb4 = 0. c loop as little as possible here! do 45 icyc= 1, ncyc c ........ theoretically best step optstp = dsqrt(dfmin/(abs(g2(i))+epspri)) c step cannot decrease by more than a factor of ten step = max(optstp, abs(0.1*gstep(i))) c but if parameter has limits, max step size = 0.5 if (gstep(i).lt.zero .and. step.gt.0.5) step=0.5 c and not more than ten times the previous step stpmax = 10.*abs(gstep(i)) if (step .gt. stpmax) step = stpmax c minimum step size allowed by machine precision stpmin = 8. * abs(epsma2*x(i)) if (step .lt. stpmin) step = stpmin c end of iterations if step change less than factor 2 if (abs((step-stepb4)/step) .lt. tlrstp) go to 50 c take step positive gstep(i) = sign(step, gstep(i)) stepb4 = step x(i) = xtf + step call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn=nfcn+1 c take step negative x(i) = xtf - step call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn=nfcn+1 grbfor = grd(i) grd(i) = (fs1-fs2)/(2.0*step) g2(i) = (fs1+fs2-2.0*amin)/(step**2) x(i) = xtf if (ldebug) then d1d2 = (fs1+fs2-2.0*amin)/step write (isyswr,41) i,grd(i),step,stpmin,optstp,d1d2,g2(i) 41 format (i4,2g11.3,5g10.2) endif c see if another iteration is necessary if (abs(grbfor-grd(i))/(abs(grd(i))+dfmin/step) .lt. tlrgrd) + go to 50 45 continue c end of icyc loop. too many iterations if (ncyc .eq. 1) go to 50 write (cbf1,'(2e11.3)') grd(i),grbfor call mnwarn('d','mnderi', + 'first derivative not converged. '//cbf1) 50 continue c 60 continue call mninex(x) return c . derivatives calc by fcn 100 do 150 iint= 1, npar iext = nexofi(iint) if (nvarl(iext) .gt. 1) go to 120 grd(iint) = gin(iext) go to 150 120 dd = (blim(iext)-alim(iext))*0.5 *dcos(x(iint)) grd(iint) = gin(iext)*dd 150 continue 200 return end cdeck id>, mndxdi. subroutine mndxdi(pint,ipar,dxdi) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the transformation factor between external and cc internal parameter values. this factor is one for cc parameters which are not limited. called from mnemat. 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 i = nexofi(ipar) dxdi = 1.0 if (nvarl(i) .gt. 1) + dxdi = 0.5 *abs((blim(i)-alim(i)) * dcos(pint)) return end cdeck id>, mneig. subroutine mneig(a,ndima,n,mits,work,precis,ifault) c ************ double precision version ************* implicit double precision (a-h,o-z) c dimension a(ndima,*),work(*) data zero,one,two/0.0,1.0,2.0/ data tol/1.0e-35/ c precis is the machine precision epsmac ifault = 1 c i = n do 70 i1 = 2,n l = i-2 f = a(i,i-1) gl = zero c if(l .lt. 1) go to 25 c do 20 k = 1,l 20 gl = gl+a(i,k)**2 25 h = gl + f**2 c if(gl .gt. tol) go to 30 c work(i) = zero work(n+i) = f go to 65 30 l = l+1 c gl = dsqrt(h) c if(f .ge. zero) gl = -gl c work(n+i) = gl h = h-f*gl a(i,i-1) = f-gl f = zero do 50 j = 1,l a(j,i) = a(i,j)/h gl = zero do 40 k = 1,j 40 gl = gl+a(j,k)*a(i,k) c if(j .ge. l) go to 47 c j1 = j+1 do 45 k = j1,l 45 gl = gl+a(k,j)*a(i,k) 47 work(n+j) = gl/h f = f+gl*a(j,i) 50 continue hh = f/(h+h) do 60 j = 1,l f = a(i,j) gl = work(n+j)-hh*f work(n+j) = gl do 60 k = 1,j a(j,k) = a(j,k)-f*work(n+k)-gl*a(i,k) 60 continue work(i) = h 65 i = i-1 70 continue work(1) = zero work(n+1) = zero do 110 i = 1,n l = i-1 c if(work(i) .eq. zero .or. l .eq. 0) go to 100 c do 90 j = 1,l gl = zero do 80 k = 1,l 80 gl = gl+a(i,k)*a(k,j) do 90 k = 1,l a(k,j) = a(k,j)-gl*a(k,i) 90 continue 100 work(i) = a(i,i) a(i,i) = one c if(l .eq. 0) go to 110 c do 105 j = 1,l a(i,j) = zero a(j,i) = zero 105 continue 110 continue c c n1 = n-1 do 130 i = 2,n i0 = n+i-1 130 work(i0) = work(i0+1) work(n+n) = zero b = zero f = zero do 210 l = 1,n j = 0 h = precis*(abs(work(l))+abs(work(n+l))) c if(b .lt. h) b = h c do 140 m1 = l,n m = m1 c if(abs(work(n+m)) .le. b) go to 150 c 140 continue c 150 if(m .eq. l) go to 205 c 160 if(j .eq. mits) return c j = j+1 pt = (work(l+1)-work(l))/(two*work(n+l)) r = dsqrt(pt*pt+one) pr = pt+r c if(pt .lt. zero) pr=pt-r c h = work(l)-work(n+l)/pr do 170 i=l,n 170 work(i) = work(i)-h f = f+h pt = work(m) c = one s = zero m1 = m-1 i = m do 200 i1 = l,m1 j = i i = i-1 gl = c*work(n+i) h = c*pt c if(abs(pt) .ge. abs(work(n+i))) go to 180 c c = pt/work(n+i) r = dsqrt(c*c+one) work(n+j) = s*work(n+i)*r s = one/r c = c/r go to 190 180 c = work(n+i)/pt r = dsqrt(c*c+one) work(n+j) = s*pt*r s = c/r c = one/r 190 pt = c*work(i)-s*gl work(j) = h+s*(c*gl+s*work(i)) do 200 k = 1,n h = a(k,j) a(k,j) = s*a(k,i)+c*h a(k,i) = c*a(k,i)-s*h 200 continue work(n+l) = s*pt work(l) = c*pt c if(abs(work(n+l)) .gt. b) go to 160 c 205 work(l) = work(l)+f 210 continue do 240 i=1,n1 k = i pt = work(i) i1 = i+1 do 220 j = i1,n c if(work(j) .ge. pt) go to 220 c k = j pt = work(j) 220 continue c if(k .eq. i) go to 240 c work(k) = work(i) work(i) = pt do 230 j=1,n pt = a(j,i) a(j,i) = a(j,k) a(j,k) = pt 230 continue 240 continue ifault = 0 c return end cdeck id>, mnemat. subroutine mnemat(emat,ndim) c ************ double precision version ************* implicit double precision (a-h,o-z) dimension emat(ndim,ndim) cc calculates the external error matrix from the internal cc to be called by user, who must dimension emat at (ndim,ndim) 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 if (isw(2) .lt. 1) return if (isw(5) .ge. 2) write (isyswr,'(/a,i4,a,i3,a,g10.2)') + ' external error matrix. ndim=',ndim,' npar=',npar, + ' err def=',up c size of matrix to be printed npard = npar if (ndim .lt. npar) then npard = ndim if (isw(5) .ge. 0) write (isyswr,'(a,a)') ' user-dimensioned ', + ' array emat not big enough. reduced matrix calculated.' endif c nperln is the number of elements that fit on one line nperln = (npagwd-5)/10 nperln = min(nperln,13) if (isw(5).ge. 1 .and. npard.gt.nperln) write (isyswr,'(a)') + ' elements above diagonal are not printed.' c i counts the rows of the matrix do 110 i= 1, npard call mndxdi(x(i),i,dxdi) kga = i*(i-1)/2 do 100 j= 1, i call mndxdi(x(j),j,dxdj) kgb = kga + j emat(i,j) = dxdi * vhmat(kgb) * dxdj * up emat(j,i) = emat(i,j) 100 continue 110 continue c iz is number of columns to be printed in row i if (isw(5) .ge. 2) then do 160 i= 1, npard iz = npard if (npard .ge. nperln) iz = i do 150 k= 1, iz, nperln k2 = k + nperln - 1 if (k2 .gt. iz) k2=iz write (isyswr,'(1x,13e10.3)') (emat(i,kk),kk=k,k2) 150 continue 160 continue endif return end cdeck id>, mnerrs. subroutine mnerrs(number,eplus,eminus,eparab,gcc) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user, utility routine to get minos errors cc if number is positive, then it is external parameter number, cc if negative, it is -internal number. cc values returned by mnerrs: cc eplus, eminus are minos errors of parameter number, cc eparab is 'parabolic' error (from error matrix). cc (errors not calculated are set = 0.) cc gcc is global correlation coefficient from error matrix 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 c iex = number if (number .lt. 0) then iin = -number if (iin .gt. npar) go to 900 iex = nexofi(iin) endif if (iex .gt. nu .or. iex .le. 0) go to 900 iin = niofex(iex) if (iin .le. 0) go to 900 c iex is external number, iin is internal number eplus = erp(iin) if (eplus.eq.undefi) eplus=0. eminus= ern(iin) if (eminus.eq.undefi) eminus=0. call mndxdi(x(iin),iin,dxdi) ndiag = iin*(iin+1)/2 eparab = abs(dxdi*dsqrt(abs(up*vhmat(ndiag)))) c global correlation coefficient gcc = 0. if (isw(2) .lt. 2) go to 990 gcc = globcc(iin) go to 990 c error. parameter number not valid 900 eplus = 0. eminus = 0. eparab = 0. gcc = 0. 990 return end cdeck id>, mneval. subroutine mneval(fcn,anext,fnext,ierev,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc evaluates the function being analyzed by mncros, which is cc generally the minimum of fcn with respect to all remaining cc variable parameters. common block /mn7xcr/ contains the cc data necessary to know the values of u(ke1cr) and u(ke2cr) cc to be used, namely u(ke1cr) = xmidcr + anext*xdircr cc and (if ke2cr .ne. 0) u(ke2cr) = ymidcr + anext*ydircr 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 cc external fcn,futil u(ke1cr) = xmidcr + anext*xdircr if ( ke2cr .ne. 0) u(ke2cr) = ymidcr + anext*ydircr call mninex(x) nparx = npar call fcn(nparx,gin,fnext,u,4,futil) nfcn = nfcn + 1 ierev = 0 if (npar .gt. 0) then itaur = 1 amin = fnext isw(1) = 0 call mnmigr(fcn,futil) itaur = 0 fnext = amin if (isw(1) .ge. 1) ierev = 1 if (isw(4) .lt. 1) ierev = 2 endif return end cdeck id>, mnexcm. subroutine mnexcm(fcn,comand,plist,llist,ierflg,futil) 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 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! dimension isort(40) character*10 cname(40), cneway, chwhy*18, c26*30, cvblnk*2 logical ltofix, lfixed, lfreed 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 nname/26/ 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 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 data isort/ 17,22,13,19,20, 9,23,14,16,26, 4, 1, 5,24,11, + 10,21,15,12, 2, 6, 3, 7,18,25, 8, 1, 1, 1, 1, + 1,1,1,1,1,1,1,1,1,1/ c lk = len(comand) if (lk .gt. maxcwd) lk=maxcwd cword = comand(1:lk) 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) if (llist .gt. lnow) then write (cvblnk,'(i2)') lk c26 = '(11h **********,'//cvblnk//'x,4g12.4)' write (isyswr,c26) (plist(i),i=lnow+1,llist) endif write (isyswr, '(1h ,10(1h*))' ) 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 = 2 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) 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 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) 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 = 1 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 = 1 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 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.' 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 ' go to 5000 endif endif nfcnmx = 1000 call mncntr(fcn,ke1,ke2,ierrf,futil) ierflg = ierrf 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 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 . . . . . . . stop, end, exit 1900 it = plist(1) if (fval3 .eq. amin .or. it .gt. 0) go to 5000 iflag = 3 write (isyswr,'(/a/)') ' call to user function with iflag = 3' nparx = npar call fcn(nparx,gin,f,u,iflag,futil) nfcn = nfcn + 1 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 if (index(cword,'sho') .gt. 0) go to 700 if (index(cword,'set') .gt. 0) go to 700 write (isyswr,2301) (cname(isort(i)),i=1,nname),'parameters' 2301 format (' the commands recognized by minuit are:'/6(2x,a10)) write (isyswr,'(a)') ' see also: help set and help show' 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) 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.' 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"' 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 cdeck id>, mnexin. subroutine mnexin(pint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc transforms the external parameter values u to internal cc values in the dense array pint. subroutine mnpint is used. cc 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 dimension pint(*) limset = .false. do 100 iint= 1, npar iext = nexofi(iint) call mnpint(u(iext),iext,pinti) pint(iint) = pinti 100 continue return end cdeck id>, mnfixp. subroutine mnfixp(iint,ierr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc removes parameter iint from the internal (variable) parameter cc list, and arranges the rest of the list to fill the hole. cc 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 dimension yy(mni) c first see if it can be done ierr = 0 if (iint.gt.npar .or. iint.le.0) then ierr = 1 write (isyswr,'(a,i4)') + ' minuit error. argument to mnfixp=',iint go to 300 endif iext = nexofi(iint) if (npfix .ge. mni) then ierr = 1 write (isyswr,'(a,i4,a,i4)') ' minuit cannot fix parameter', + iext,' maximum number that can be fixed is',mni go to 300 endif c reduce number of variable parameters by one niofex(iext) = 0 nold = npar npar = npar - 1 c save values in case parameter is later restored npfix = npfix + 1 ipfix(npfix) = iext lc = iint xs(npfix) = x(lc) xts(npfix) = xt(lc) dirins(npfix) = werr(lc) grds(npfix) = grd(lc) g2s(npfix) = g2(lc) gsteps(npfix) = gstep(lc) c shift values for other parameters to fill hole do 100 ik= iext+1, nu if (niofex(ik) .gt. 0) then lc = niofex(ik) - 1 niofex(ik) = lc nexofi(lc) = ik x(lc) = x(lc+1) xt(lc) = xt(lc+1) dirin(lc) = dirin(lc+1) werr(lc) = werr(lc+1) grd(lc) = grd(lc+1) g2(lc) = g2(lc+1) gstep(lc) = gstep(lc+1) endif 100 continue if (isw(2) .le. 0) go to 300 c remove one row and one column from variance matrix if (npar .le. 0) go to 300 do 260 i= 1, nold m = max(i,iint) n = min(i,iint) ndex = m*(m-1)/2 + n 260 yy(i)=vhmat(ndex) yyover = 1.0/yy(iint) knew = 0 kold = 0 do 294 i= 1, nold do 292 j= 1, i kold = kold + 1 if (j.eq.iint .or. i.eq.iint) go to 292 knew = knew + 1 vhmat(knew) = vhmat(kold) - yy(j)*yy(i)*yyover 292 continue 294 continue 300 return end cdeck id>, mnfree. subroutine mnfree(k) c ************ double precision version ************* implicit double precision (a-h,o-z) cc restores one or more fixed parameter(s) to variable status cc by inserting it into the internal parameter list at the cc appropriate place. cc 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 c-- k = 0 means restore all parameters c-- k = 1 means restore the last parameter fixed c-- k = -i means restore external parameter i (if possible) c-- iq = fix-location where internal parameters were stored c-- ir = external number of parameter being restored c-- is = internal number of parameter being restored if (k .gt. 1) write (isyswr,510) if (npfix .lt. 1) write (isyswr,500) if (k.eq.1 .or. k.eq.0) go to 40 c release parameter with specified external number ka = iabs(k) if (niofex(ka) .eq. 0) go to 15 write (isyswr,540) 540 format (' ignored. parameter specified is already variable.') return 15 if (npfix .lt. 1) go to 21 do 20 ik= 1, npfix if (ipfix(ik) .eq. ka) go to 24 20 continue 21 write (isyswr,530) ka 530 format (' parameter',i4,' not fixed. cannot be released.') return 24 if (ik .eq. npfix) go to 40 c move specified parameter to end of list ipsav = ka xv = xs(ik) xtv = xts(ik) dirinv = dirins(ik) grdv = grds(ik) g2v = g2s(ik) gstepv = gsteps(ik) do 30 i= ik+1,npfix ipfix(i-1) = ipfix(i) xs(i-1) = xs(i) xts(i-1) = xts(i) dirins(i-1) = dirins(i) grds(i-1) = grds(i) g2s(i-1) = g2s(i) gsteps(i-1) = gsteps(i) 30 continue ipfix(npfix) = ipsav xs(npfix) = xv xts(npfix) = xtv dirins(npfix) = dirinv grds(npfix) = grdv g2s(npfix) = g2v gsteps(npfix) = gstepv c restore last parameter in fixed list -- ipfix(npfix) 40 continue if (npfix .lt. 1) go to 300 ir = ipfix(npfix) is = 0 do 100 ik= nu, ir, -1 if (niofex(ik) .gt. 0) then lc = niofex(ik) + 1 is = lc - 1 niofex(ik) = lc nexofi(lc) = ik x(lc) = x(lc-1) xt(lc) = xt(lc-1) dirin(lc) = dirin(lc-1) werr(lc) = werr(lc-1) grd(lc) = grd(lc-1) g2(lc) = g2(lc-1) gstep(lc) = gstep(lc-1) endif 100 continue npar = npar + 1 if (is .eq. 0) is = npar niofex(ir) = is nexofi(is) = ir iq = npfix x(is) = xs(iq) xt(is) = xts(iq) dirin(is) = dirins(iq) werr(is) = dirins(iq) grd(is) = grds(iq) g2(is) = g2s(iq) gstep(is) = gsteps(iq) npfix = npfix - 1 isw(2) = 0 dcovar = 1. if (itaur .lt. 1) write(isyswr,520) ir,cpnam(ir) if (k.eq.0) go to 40 300 continue c if different from internal, external values are taken call mnexin(x) 400 return 500 format (' call to mnfree ignored. there are no fixed pa', + 'rameters'/) 510 format (' call to mnfree ignored. argument greater than one'/) 520 format (20x, 9hparameter,i4,2h, ,a10,' restored to variable.') end cdeck id>, mngrad. subroutine mngrad(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnset cc interprets the set grad command, which informs minuit whether cc the first derivatives of fcn will be calculated by the user cc inside fcn. it can check the user's derivative calculation cc by comparing it with a finite difference approximation. cc 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 c external fcn,futil character*4 cgood,cbad,cnone,cwd logical lnone dimension gf(mni) parameter (cgood='good',cbad=' bad',cnone='none') c isw(3) = 1 nparx = npar if (word7(1) .gt. zero) go to 2000 c get user-calculated first derivatives from fcn do 30 i= 1, nu 30 gin(i) = undefi call mninex(x) call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 call mnderi(fcn,futil) do 40 i= 1, npar 40 gf(i) = grd(i) c get minuit-calculated first derivatives isw(3) = 0 istsav = istrat istrat = 2 call mnhes1(fcn,futil) istrat = istsav write (isyswr,51) 51 format(/' check of gradient calculation in fcn'/12x,'parameter', + 6x,9hg(in fcn) ,3x,9hg(minuit) ,2x,'dg(minuit)',3x,9hagreement) isw(3) = 1 lnone = .false. do 100 lc = 1, npar i = nexofi(lc) cwd = cgood err = dgrd(lc) if (abs(gf(lc)-grd(lc)) .gt. err) cwd = cbad if (gin(i) .eq. undefi) then cwd = cnone lnone = .true. gf(lc) = 0. endif if (cwd .ne. cgood) isw(3) = 0 write (isyswr,99) i,cpnam(i),gf(lc),grd(lc),err,cwd 99 format (7x,i5,2x ,a10,3e12.4,4x ,a4) 100 continue if (lnone) write (isyswr,'(a)') + ' agreement=none means fcn did not calculate the derivative' if (isw(3) .eq. 0) write (isyswr,1003) 1003 format(/' minuit does not accept derivative calculations by fcn'/ + ' to force acceptance, enter "set grad 1"'/) c 2000 continue return end cdeck id>, mnhess. subroutine mnhess(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the full second-derivative matrix of fcn cc by taking finite differences. when calculating diagonal cc elements, it may iterate so that step size is nearly that cc which gives function change= up/10. the first derivatives cc of course come as a free side effect, but with a smaller cc step size in order to obtain a known accuracy. cc 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 dimension yy(mni) logical ldebug character cbf1*22 c ldebug = (idbg(3) .ge. 1) if (amin .eq. undefi) call mnamin(fcn,futil) if (istrat .le. 0) then ncyc = 3 tlrstp = 0.5 tlrg2 = 0.1 else if (istrat .eq. 1) then ncyc = 5 tlrstp = 0.3 tlrg2 = 0.05 else ncyc = 7 tlrstp = 0.1 tlrg2 = 0.02 endif if (isw(5).ge.2 .or. ldebug) write (isyswr,'(a)') + ' start covariance matrix calculation.' cfrom = 'hesse ' nfcnfr = nfcn cstatu= 'ok ' npard = npar c make sure starting at the right place call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 if (fs1 .ne. amin) then df = amin - fs1 write (cbf1(1:12),'(g12.3)') df call mnwarn('d','mnhess', + 'function value differs from amin by '//cbf1(1:12) ) endif amin = fs1 if (ldebug) write (isyswr,'(a,a)') ' par d gstep ', +' d g2 grd sag ' c . . . . . . diagonal elements . c isw(2) = 1 if approx, 2 if not posdef, 3 if ok c aimsag is the sagitta we are aiming for in second deriv calc. aimsag = dsqrt(epsma2)*(abs(amin)+up) c zero the second derivative matrix npar2 = npar*(npar+1)/2 do 10 i= 1,npar2 10 vhmat(i) = 0. c c loop over variable parameters for second derivatives idrv = 2 do 100 id= 1, npard i = id + npar - npard if (g2(i) .eq. zero) then call mnwarn('d','mnhess', + 'a second derivative is zero on entering.') wint = werr(i) iext = nexofi(i) if (nvarl(iext) .gt. 1) then call mndxdi(x(i),i,dxdi) if (abs(dxdi) .lt. .001) then wint = .01 else wint = wint/abs(dxdi) endif endif g2(i) = up/wint**2 endif xtf = x(i) dmin = 8.*epsma2*abs(xtf) c c find step which gives sagitta = aimsag d = abs(gstep(i)) do 40 icyc= 1, ncyc c loop here only if sag=0. do 25 multpy= 1, 5 c take two steps x(i) = xtf + d call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xtf - d call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn = nfcn + 1 x(i) = xtf sag = 0.5*(fs1+fs2-2.0*amin) if (sag .ne. zero) go to 30 if (gstep(i) .lt. zero) then if (d .ge. .5) go to 26 d = 10.*d if (d .gt. 0.5) d = 0.51 go to 25 endif d = 10.*d 25 continue 26 write (cbf1(1:4),'(i4)') iext call mnwarn('w','hesse', + 'second derivative zero for parameter'//cbf1(1:4) ) go to 390 c sag is not zero 30 g2bfor = g2(i) g2(i) = 2.*sag/d**2 grd(i) = (fs1-fs2)/(2.*d) if (ldebug) write (isyswr,31) i,idrv,gstep(i),d,g2(i),grd(i),sag 31 format (i4,i2,6g12.5) gstep(i) = sign(d,gstep(i)) dirin(i) = d yy(i) = fs1 dlast = d d = dsqrt(2.0*aimsag/abs(g2(i))) c if parameter has limits, max int step size = 0.5 stpinm = 0.5 if (gstep(i) .lt. zero) d = min(d,stpinm) if (d .lt. dmin) d = dmin c see if converged if (abs((d-dlast)/d) .lt. tlrstp) go to 50 if (abs((g2(i)-g2bfor)/g2(i)) .lt. tlrg2 ) go to 50 d = min(d, 10.*dlast) d = max(d, 0.1*dlast) 40 continue c end of step size loop write (cbf1,'(i2,2e10.2)') iext,sag,aimsag call mnwarn('d','mnhess','second deriv. sag,aim= '//cbf1) c 50 continue ndex = i*(i+1)/2 vhmat(ndex) = g2(i) 100 continue c end of diagonal second derivative loop call mninex(x) c refine the first derivatives if (istrat .gt. 0) call mnhes1(fcn,futil) isw(2) = 3 dcovar = 0. c . . . . off-diagonal elements if (npar .eq. 1) go to 214 do 200 i= 1, npar do 180 j= 1, i-1 xti = x(i) xtj = x(j) x(i) = xti + dirin(i) x(j) = xtj + dirin(j) call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xti x(j) = xtj elem = (fs1+amin-yy(i)-yy(j)) / (dirin(i)*dirin(j)) ndex = i*(i-1)/2 + j vhmat(ndex) = elem 180 continue 200 continue 214 call mninex(x) c verify matrix positive-definite call mnpsdf do 220 i= 1, npar do 219 j= 1, i ndex = i*(i-1)/2 + j p(i,j) = vhmat(ndex) 219 p(j,i) = p(i,j) 220 continue call mnvert(p,maxint,maxint,npar,ifail) if (ifail .gt. 0) then call mnwarn('w','hesse', 'matrix inversion fails.') go to 390 endif c . . . . . . . calculate e d m edm = 0. do 230 i= 1, npar c off-diagonal elements ndex = i*(i-1)/2 do 225 j= 1, i-1 ndex = ndex + 1 ztemp = 2.0 * p(i,j) edm = edm + grd(i)*ztemp*grd(j) 225 vhmat(ndex) = ztemp c diagonal elements ndex = ndex + 1 vhmat(ndex) = 2.0 * p(i,i) edm = edm + p(i,i) * grd(i)**2 230 continue if (isw(5).ge.1 .and. isw(2).eq.3 .and. itaur.eq.0) + write(isyswr,'(a)')' covariance matrix calculated successfully' go to 900 c failure to invert 2nd deriv matrix 390 isw(2) = 1 dcovar = 1. cstatu = 'failed ' if (isw(5) .ge. 0) write (isyswr,'(a)') + ' mnhess fails and will return diagonal matrix. ' do 395 i= 1, npar ndex = i*(i-1)/2 do 394 j= 1, i-1 ndex = ndex + 1 394 vhmat(ndex) = 0.0 ndex = ndex +1 g2i = g2(i) if (g2i .le. zero) g2i = 1.0 395 vhmat(ndex) = 2.0/g2i 900 return end cdeck id>, mnhes1. subroutine mnhes1(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnhess and mngrad cc calculate first derivatives (grd) and uncertainties (dgrd) cc and appropriate step sizes gstep 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 logical ldebug character cbf1*22 ldebug = (idbg(5) .ge. 1) if (istrat .le. 0) ncyc = 1 if (istrat .eq. 1) ncyc = 2 if (istrat .gt. 1) ncyc = 6 idrv = 1 nparx = npar dfmin = 4.*epsma2*(abs(amin)+up) c main loop over parameters do 100 i= 1, npar xtf = x(i) dmin = 4.*epsma2*abs(xtf) epspri = epsma2 + abs(grd(i)*epsma2) optstp = dsqrt(dfmin/(abs(g2(i))+epspri)) d = 0.2 * abs(gstep(i)) if (d .gt. optstp) d = optstp if (d .lt. dmin) d = dmin chgold = 10000. c iterate reducing step size do 50 icyc= 1, ncyc x(i) = xtf + d call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xtf - d call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn = nfcn + 1 x(i) = xtf c check if step sizes appropriate sag = 0.5*(fs1+fs2-2.0*amin) grdold = grd(i) grdnew = (fs1-fs2)/(2.0*d) dgmin = epsmac*(abs(fs1)+abs(fs2))/d if (ldebug) write (isyswr,11) i,idrv,gstep(i),d,g2(i),grdnew,sag 11 format (i4,i2,6g12.5) if (grdnew .eq. zero) go to 60 change = abs((grdold-grdnew)/grdnew) if (change.gt.chgold .and. icyc.gt.1) go to 60 chgold = change grd(i) = grdnew gstep(i) = sign(d,gstep(i)) c decrease step until first derivative changes by <5% if (change .lt. 0.05) go to 60 if (abs(grdold-grdnew) .lt. dgmin) go to 60 if (d .lt. dmin) then call mnwarn('d','mnhes1','step size too small for 1st drv.') go to 60 endif d = 0.2*d 50 continue c loop satisfied = too many iter write (cbf1,'(2g11.3)') grdold,grdnew call mnwarn('d','mnhes1','too many iterations on d1.'//cbf1) 60 continue dgrd(i) = max(dgmin,abs(grdold-grdnew)) 100 continue c end of first deriv. loop call mninex(x) return end cdeck id>, mnimpr. subroutine mnimpr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc attempts to improve on a good local minimum by finding a cc better one. the quadratic part of fcn is removed by mncalf cc and this transformed function is minimized using the simplex cc method from several random starting points. cc ref. -- goldstein and price, math.comp. 25, 569 (1971) cc 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 dimension dsav(mni), y(mni+1) parameter (alpha=1.,beta=0.5,gamma=2.0) data rnum/0./ if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) cstatu = 'unchanged ' itaur = 1 epsi = 0.1*up npfn=nfcn nloop = word7(2) if (nloop .le. 0) nloop = npar + 4 nparx = npar nparp1=npar+1 wg = 1.0/float(npar) sigsav = edm apsi = amin do 2 i= 1, npar xt(i) = x(i) dsav(i) = werr(i) do 2 j = 1, i ndex = i*(i-1)/2 + j p(i,j) = vhmat(ndex) 2 p(j,i) = p(i,j) call mnvert(p,maxint,maxint,npar,ifail) if (ifail .ge. 1) go to 280 c save inverted matrix in vt do 12 i= 1, npar ndex = i*(i-1)/2 do 12 j= 1, i ndex = ndex + 1 12 vthmat(ndex) = p(i,j) loop = 0 c 20 continue do 25 i= 1, npar dirin(i) = 2.0*dsav(i) call mnrn15(rnum,iseed) 25 x(i) = xt(i) + 2.0*dirin(i)*(rnum-0.5) loop = loop + 1 reg = 2.0 if (isw(5) .ge. 0) write (isyswr, 1040) loop 30 call mncalf(fcn,x,ycalf,futil) amin = ycalf c . . . . set up random simplex jl = nparp1 jh = nparp1 y(nparp1) = amin amax = amin do 45 i= 1, npar xi = x(i) call mnrn15(rnum,iseed) x(i) = xi - dirin(i) *(rnum-0.5) call mncalf(fcn,x,ycalf,futil) y(i) = ycalf if (y(i) .lt. amin) then amin = y(i) jl = i else if (y(i) .gt. amax) then amax = y(i) jh = i endif do 40 j= 1, npar 40 p(j,i) = x(j) p(i,nparp1) = xi x(i) = xi 45 continue c edm = amin sig2 = edm c . . . . . . . start main loop 50 continue if (amin .lt. zero) go to 95 if (isw(2) .le. 2) go to 280 ep = 0.1*amin if (sig2 .lt. ep .and. edm.lt.ep ) go to 100 sig2 = edm if ((nfcn-npfn) .gt. nfcnmx) go to 300 c calculate new point * by reflection do 60 i= 1, npar pb = 0. do 59 j= 1, nparp1 59 pb = pb + wg * p(i,j) pbar(i) = pb - wg * p(i,jh) 60 pstar(i)=(1.+alpha)*pbar(i)-alpha*p(i,jh) call mncalf(fcn,pstar,ycalf,futil) ystar = ycalf if(ystar.ge.amin) go to 70 c point * better than jl, calculate new point ** do 61 i=1,npar 61 pstst(i)=gamma*pstar(i)+(1.-gamma)*pbar(i) call mncalf(fcn,pstst,ycalf,futil) ystst = ycalf 66 if (ystst .lt. y(jl)) go to 67 call mnrazz(ystar,pstar,y,jh,jl) go to 50 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c point * is not as good as jl 70 if (ystar .ge. y(jh)) go to 73 jhold = jh call mnrazz(ystar,pstar,y,jh,jl) if (jhold .ne. jh) go to 50 c calculate new point ** 73 do 74 i=1,npar 74 pstst(i)=beta*p(i,jh)+(1.-beta)*pbar(i) call mncalf(fcn,pstst,ycalf,futil) ystst = ycalf if(ystst.gt.y(jh)) go to 30 c point ** is better than jh if (ystst .lt. amin) go to 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c . . . . . . end main loop 95 if (isw(5) .ge. 0) write (isyswr,1000) reg = 0.1 c . . . . . ask if point is new 100 call mninex(x) call fcn(nparx,gin,amin,u,4,futil) nfcn = nfcn + 1 do 120 i= 1, npar dirin(i) = reg*dsav(i) if (abs(x(i)-xt(i)) .gt. dirin(i)) go to 150 120 continue go to 230 150 nfcnmx = nfcnmx + npfn - nfcn npfn = nfcn call mnsimp(fcn,futil) if (amin .ge. apsi) go to 325 do 220 i= 1, npar dirin(i) = 0.1 *dsav(i) if (abs(x(i)-xt(i)) .gt. dirin(i)) go to 250 220 continue 230 if (amin .lt. apsi) go to 350 go to 325 c . . . . . . truly new minimum 250 lnewmn = .true. if (isw(2) .ge. 1) then isw(2) = 1 dcovar = max(dcovar,half) else dcovar = 1. endif itaur = 0 nfcnmx = nfcnmx + npfn - nfcn cstatu = 'new minimu' if (isw(5) .ge. 0) write (isyswr,1030) return c . . . return to previous region 280 if (isw(5) .gt. 0) write (isyswr,1020) go to 325 300 isw(1) = 1 325 do 330 i= 1, npar dirin(i) = 0.01*dsav(i) 330 x(i) = xt(i) amin = apsi edm = sigsav 350 call mninex(x) if (isw(5) .gt. 0) write (isyswr,1010) cstatu= 'unchanged ' call mnrset(0) if (isw(2) .lt. 2) go to 380 if (loop .lt. nloop .and. isw(1) .lt. 1) go to 20 380 call mnprin (5,amin) itaur = 0 return 1000 format (54h an improvement on the previous minimum has been found) 1010 format (51h improve has returned to region of original minimum) 1020 format (/44h covariance matrix was not positive-definite) 1030 format (/38h improve has found a truly new minimum/1h ,37(1h*)/) 1040 format (/18h start attempt no.,i2, 20h to find new minimum) end cdeck id>, mninex. subroutine mninex(pint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc transforms from internal coordinates (pint) to external cc parameters (u). the minimizing routines which work in cc internal coordinates call this routine before calling fcn. 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 dimension pint(*) do 100 j= 1, npar i = nexofi(j) if (nvarl(i) .eq. 1) then u(i) = pint(j) else u(i) = alim(i) + 0.5*(dsin(pint(j)) +1.0) * (blim(i)-alim(i)) endif 100 continue return end cdeck id>, mninit. subroutine mninit (i1,i2,i3) c ************ double precision version ************* implicit double precision (a-h,o-z) cc this is the main initialization subroutine for minuit cc it initializes some constants in common cc (including the logical i/o unit nos.), cc 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 c external intrac logical intrac c i/o unit numbers isysrd = i1 isyswr = i2 istkwr(1) = isyswr nstkwr = 1 isyssa = i3 nstkrd = 0 c version identifier cvrsn = '90.10 ' c some constant constants in common maxint=mni maxext=mne undefi = -54321. bigedm = 123456. cundef = ')undefined' covmes(0) = 'no error matrix ' covmes(1) = 'err matrix approximate' covmes(2) = 'err matrix not pos-def' covmes(3) = 'error matrix accurate ' c some starting values in common nblock = 0 icomnd = 0 ctitl = cundef cfrom = 'input ' nfcnfr = nfcn cstatu= 'initialize' isw(3) = 0 isw(4) = 0 isw(5) = 1 c isw(6)=0 for batch jobs, =1 for interactive jobs isw(6) = 0 if (intrac(dummy)) isw(6) = 1 c debug options set to default values do 10 idb= 0, maxdbg 10 idbg(idb) = 0 lrepor = .false. lwarn = .true. limset = .false. lnewmn = .false. istrat = 1 itaur = 0 c default page dimensions and 'new page' carriage control integer npagwd = 120 npagln = 56 newpag = 1 if (isw(6) .gt. 0) then npagwd = 80 npagln = 30 newpag = 0 endif up = 1.0 updflt = up c determine machine accuracy epsmac epstry = 0.5 do 33 i= 1, 100 epstry = epstry * 0.5 epsp1 = one + epstry call mntiny(epsp1, epsbak) if (epsbak .lt. epstry) go to 35 33 continue epstry = 1.0e-7 epsmac = 4.0*epstry write (isyswr,'(a,a,e10.2)') ' mninit unable to determine', + ' arithmetic precision. will assume:',epsmac 35 epsmac = 8.0 * epstry epsma2 = 2.0 * dsqrt(epsmac) c the vlims are a non-negligible distance from pi/2 c used by mnpint to set variables "near" the physical limits piby2 = 2.0*atan(1.0) distnn = 8.0*dsqrt(epsma2) vlimhi = piby2 - distnn vlimlo = -piby2 + distnn call mncler write (isyswr,'(3a,i3,a,i3,a,e10.2)') ' minuit release ',cvrsn, +' initialized. dimensions ',mne,'/',mni,' epsmac=',epsmac return end cdeck id>, mnintr. subroutine mnintr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user. interfaces to mnread to allow user to change cc easily from fortran-callable to interactive mode. cc 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 iflgin = 3 call mnread(fcn,iflgin,iflgut,futil) write (isyswr,'(2a/)') ' end of minuit command input. ', + ' return to user program.' return end cdeck id>, mnlims. subroutine mnlims(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnset cc interprets the set lim command, to reset the parameter limits cc 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 c cfrom = 'set lim ' nfcnfr = nfcn cstatu= 'no change ' i2 = word7(1) if (i2 .gt. maxext .or. i2 .lt. 0) go to 900 if (i2 .gt. 0) go to 30 c set limits on all parameters newcod = 4 if (word7(2) .eq. word7(3)) newcod = 1 do 20 inu= 1, nu if (nvarl(inu) .le. 0) go to 20 if (nvarl(inu).eq.1 .and. newcod.eq.1) go to 20 kint = niofex(inu) c see if parameter has been fixed if (kint .le. 0) then if (isw(5) .ge. 0) write (isyswr,'(11x,a,i3)') + ' limits not changed for fixed parameter:',inu go to 20 endif if (newcod .eq. 1) then c remove limits from parameter if (isw(5) .gt. 0) write (isyswr,134) inu cstatu = 'new limits' call mndxdi(x(kint),kint,dxdi) snew = gstep(kint)*dxdi gstep(kint) = abs(snew) nvarl(inu) = 1 else c put limits on parameter alim(inu) = min(word7(2),word7(3)) blim(inu) = max(word7(2),word7(3)) if (isw(5) .gt. 0) write (isyswr,237) inu,alim(inu),blim(inu) nvarl(inu) = 4 cstatu = 'new limits' gstep(kint) = -0.1 endif 20 continue go to 900 c set limits on one parameter 30 if (nvarl(i2) .le. 0) then write (isyswr,'(a,i3,a)') ' parameter ',i2,' is not variable.' go to 900 endif kint = niofex(i2) c see if parameter was fixed if (kint .eq. 0) then write (isyswr,'(a,i3)') + ' request to change limits on fixed parameter:',i2 do 82 ifx= 1, npfix if (i2 .eq. ipfix(ifx)) go to 92 82 continue write (isyswr,'(a)') ' minuit bug in mnlims. see f. james' 92 continue endif if (word7(2) .ne. word7(3)) go to 235 c remove limits if (nvarl(i2) .ne. 1) then if (isw(5) .gt. 0) write (isyswr,134) i2 134 format (30h limits removed from parameter ,i4) cstatu = 'new limits' if (kint .le. 0) then gsteps(ifx) = abs(gsteps(ifx)) else call mndxdi(x(kint),kint,dxdi) if (abs(dxdi) .lt. 0.01) dxdi=0.01 gstep(kint) = abs(gstep(kint)*dxdi) grd(kint) = grd(kint)*dxdi endif nvarl(i2) = 1 else write (isyswr,'(a,i3)') ' no limits specified. parameter ', + i2,' is already unlimited. no change.' endif go to 900 c put on limits 235 alim(i2) = min(word7(2),word7(3)) blim(i2) = max(word7(2),word7(3)) nvarl(i2) = 4 if (isw(5) .gt. 0) write (isyswr,237) i2,alim(i2),blim(i2) 237 format (10h parameter ,i3, 14h limits set to ,2g15.5) cstatu = 'new limits' if (kint .le. 0) then gsteps(ifx) = -0.1 else gstep(kint) = -0.1 endif c 900 continue if (cstatu .ne. 'no change ') then call mnexin(x) call mnrset(1) endif return end cdeck id>, mnline. subroutine mnline(fcn,start,fstart,step,slope,toler,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc perform a line search from position start cc along direction step, where the length of vector step cc gives the expected position of minimum. cc fstart is value of function at start cc slope (if non-zero) is df/dx along step at start cc toler is initial tolerance of minimum in direction step 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 dimension start(*), step(*) parameter (maxpt=12) dimension xpq(maxpt),ypq(maxpt) character*1 chpq(maxpt) dimension xvals(3),fvals(3),coeff(3) character*26 charal character*60 cmess parameter (slambg=5.,alpha=2.) c slambg and alpha control the maximum individual steps allowed. c the first step is always =1. the max length of second step is slambg. c the max size of subsequent steps is the maximum previous successful c step multiplied by alpha + the size of most recent successful step, c but cannot be smaller than slambg. logical ldebug data charal / 'abcdefghijklmnopqrstuvwxyz' / ldebug = (idbg(1).ge.1) c starting values for overall limits on total step slam overal = 1000. undral = -100. c debug check if start is ok if (ldebug) then call mninex(start) call fcn(nparx,gin,f1,u,4,futil) nfcn=nfcn+1 if (f1 .ne. fstart) then write (isyswr,'(a/2e14.5/2x,10f10.5)') + ' mnline start point not consistent, f values, parameters=', + (x(kk),kk=1,npar) endif endif c . set up linear search along step fvmin = fstart xvmin = 0. nxypt = 1 chpq(1) = charal(1:1) xpq(1) = 0. ypq(1) = fstart c slamin = smallest possible value of abs(slam) slamin = 0. do 20 i= 1, npar if (step(i) .eq. zero) go to 20 ratio = abs(start(i)/step(i)) if (slamin .eq. zero) slamin = ratio if (ratio .lt. slamin) slamin = ratio 20 x(i) = start(i) + step(i) if (slamin .eq. zero) slamin = epsmac slamin = slamin*epsma2 nparx = npar c call mninex(x) call fcn(nparx,gin,f1,u,4,futil) nfcn=nfcn+1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = 1. ypq(nxypt) = f1 if (f1 .lt. fstart) then fvmin = f1 xvmin = 1.0 endif c . quadr interp using slope gdel and two points slam = 1. toler8 = toler slamax = slambg flast = f1 c can iterate on two-points (cut) if no imprvmnt 25 continue denom = 2.0*(flast-fstart-slope*slam)/slam**2 c if (denom .eq. zero) denom = -0.1*slope slam = 1. if (denom .ne. zero) slam = -slope/denom if (slam .lt. zero) slam = slamax if (slam .gt. slamax) slam = slamax if (slam .lt. toler8) slam = toler8 if (slam .lt. slamin) go to 80 if (abs(slam-1.0).lt.toler8 .and. f1.lt.fstart) go to 70 if (abs(slam-1.0).lt.toler8) slam = 1.0+toler8 if (nxypt .ge. maxpt) go to 65 do 30 i= 1, npar 30 x(i) = start(i) + slam*step(i) call mninex(x) call fcn(npar,gin,f2,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = slam ypq(nxypt) = f2 if (f2 .lt. fvmin) then fvmin = f2 xvmin = slam endif if (fstart .eq. fvmin) then flast = f2 toler8 = toler*slam overal = slam-toler8 slamax = overal go to 25 endif c . quadr interp using 3 points xvals(1) = xpq(1) fvals(1) = ypq(1) xvals(2) = xpq(nxypt-1) fvals(2) = ypq(nxypt-1) xvals(3) = xpq(nxypt) fvals(3) = ypq(nxypt) c begin iteration, calculate desired step 50 continue slamax = max(slamax,alpha*abs(xvmin)) call mnpfit(xvals,fvals,3,coeff,sdev) if (coeff(3) .le. zero) then slopem = 2.0*coeff(3)*xvmin + coeff(2) if (slopem .le. zero) then slam = xvmin + slamax else slam = xvmin - slamax endif else slam = -coeff(2)/(2.0*coeff(3)) if (slam .gt. xvmin+slamax) slam = xvmin+slamax if (slam .lt. xvmin-slamax) slam = xvmin-slamax endif if (slam .gt. zero) then if (slam .gt. overal) slam = overal else if (slam .lt. undral) slam = undral endif c come here if step was cut below 52 continue toler9 = max(toler8,abs(toler8*slam)) do 55 ipt= 1, 3 if (abs(slam-xvals(ipt)) .lt. toler9) go to 70 55 continue c take the step do 60 i= 1, npar 60 x(i) = start(i)+slam*step(i) call mninex(x) call fcn(nparx,gin,f3,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = slam ypq(nxypt) = f3 c find worst previous point out of three fvmax = fvals(1) nvmax = 1 if (fvals(2) .gt. fvmax) then fvmax = fvals(2) nvmax = 2 endif if (fvals(3) .gt. fvmax) then fvmax = fvals(3) nvmax = 3 endif c if latest point worse than all three previous, cut step if (f3 .ge. fvmax) then if (nxypt .ge. maxpt) go to 65 if (slam .gt. xvmin) overal = min(overal,slam-toler8) if (slam .lt. xvmin) undral = max(undral,slam+toler8) slam = 0.5*(slam+xvmin) go to 52 endif c prepare another iteration, replace worst previous point xvals(nvmax) = slam fvals(nvmax) = f3 if (f3 .lt. fvmin) then fvmin = f3 xvmin = slam else if (slam .gt. xvmin) overal = min(overal,slam-toler8) if (slam .lt. xvmin) undral = max(undral,slam+toler8) endif if (nxypt .lt. maxpt) go to 50 c . . end of iteration . . . c stop because too many iterations 65 cmess = ' line search has exhausted the limit of function calls ' if (ldebug) then write (isyswr,'(a/(2x,6g12.4))') ' mnline debug: steps=', + (step(kk),kk=1,npar) endif go to 100 c stop because within tolerance 70 continue cmess = ' line search has attained tolerance ' go to 100 80 continue cmess = ' step size at arithmetically allowed minimum' 100 continue amin = fvmin do 120 i= 1, npar dirin(i) = step(i)*xvmin 120 x(i) = start(i) + dirin(i) call mninex(x) if (xvmin .lt. 0.) call mnwarn('d','mnline', + ' line minimum in backwards direction') if (fvmin .eq. fstart) call mnwarn('d','mnline', + ' line search finds no improvement ') if (ldebug) then write (isyswr,'('' after'',i3,'' points,'',a)') nxypt,cmess call mnplot(xpq,ypq,chpq,nxypt,isyswr,npagwd,npagln) endif return end cdeck id>, mnmatu. subroutine mnmatu(kode) c ************ double precision version ************* implicit double precision (a-h,o-z) cc prints the covariance matrix v when kode=1. cc always prints the global correlations, and cc calculates and prints the individual correlation coefficients cc 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 dimension vline(mni) isw2 = isw(2) if (isw2 .lt. 1) then write (isyswr,'(1x,a)') covmes(isw2) go to 500 endif if (npar .eq. 0) then write (isyswr,'('' mnmatu: npar=0'')') go to 500 endif c . . . . .external error matrix if (kode .eq. 1) then isw5 = isw(5) isw(5) = 2 call mnemat(p,maxint) if (isw2.lt.3) write (isyswr,'(1x,a)') covmes(isw2) isw(5) = isw5 endif c . . . . . correlation coeffs. . if (npar .le. 1) go to 500 call mnwerr c ncoef is number of coeff. that fit on one line, not to exceed 20 ncoef = (npagwd-19)/6 ncoef = min(ncoef,20) nparm = min(npar,ncoef) write (isyswr, 150) (nexofi(id),id=1,nparm) 150 format (/36h parameter correlation coefficients / + 18h no. global ,20i6) do 200 i= 1, npar ix = nexofi(i) ndi = i*(i+1)/2 do 170 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n ndj = j*(j+1)/2 170 vline(j) = vhmat(ndex)/dsqrt(abs(vhmat(ndi)*vhmat(ndj))) nparm = min(npar,ncoef) write (isyswr,171) ix, globcc(i), (vline(it),it=1,nparm) 171 format (6x,i3,2x,f7.5,1x,20f6.3) if (i.le.nparm) go to 200 do 190 iso= 1, 10 nsofar = nparm nparm = min(npar,nsofar+ncoef) write (isyswr,181) (vline(it),it=nsofar+1,nparm) 181 format (19x,20f6.3) if (i .le. nparm) go to 192 190 continue 192 continue 200 continue if (isw2.lt.3) write (isyswr,'(1x,a)') covmes(isw2) 500 return end cdeck id>, mnmigr. subroutine mnmigr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a local function minimization using basically the cc method of davidon-fletcher-powell as modified by fletcher cc ref. -- fletcher, comp.j. 13,317 (1970) "switching method" cc 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 dimension gs(mni), step(mni), xxs(mni), flnu(mni), vg(mni) logical ldebug parameter (toler=0.05) if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) ldebug = (idbg(4) .ge. 1) cfrom = 'migrad ' nfcnfr = nfcn nfcnmg = nfcn cstatu= 'initiate ' iswtr = isw(5) - 2*itaur npfn = nfcn nparx = npar vlen = npar*(npar+1)/2 nrstrt = 0 npsdf = 0 lined2 = 0 isw(4) = -1 rhotol = 1.0e-3*apsi if (iswtr .ge. 1) write (isyswr,470) istrat,rhotol 470 format (' start migrad minimization. strategy',i2, +'. convergence when edm .lt.',e9.2) c initialization strategy if (istrat.lt.2 .or. isw(2).ge.3) go to 2 c come (back) here to restart completely 1 continue if (nrstrt .gt. istrat) then cstatu= 'failed ' isw(4) = -1 go to 230 endif c . get full covariance and gradient call mnhess(fcn,futil) call mnwerr npsdf = 0 if (isw(2) .ge. 1) go to 10 c . get gradient at start point 2 continue call mninex(x) if (isw(3) .eq. 1) then call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 endif call mnderi(fcn,futil) if (isw(2) .ge. 1) go to 10 c sometimes start with diagonal matrix do 3 i= 1, npar xxs(i) = x(i) step(i) = zero 3 continue c do line search if second derivative negative lined2 = lined2 + 1 if (lined2 .lt. 2*npar) then do 5 i= 1, npar if (g2(i) .gt. 0.) go to 5 step(i) = -sign(gstep(i),grd(i)) gdel = step(i)*grd(i) fs = amin call mnline(fcn,xxs,fs,step,gdel,toler,futil) call mnwarn('d','mnmigr','negative g2 line search') iext = nexofi(i) if (ldebug) write (isyswr,'(a,i3,2g13.3)') + ' negative g2 line search, param ',iext,fs,amin go to 2 5 continue endif c make diagonal error matrix do 8 i=1,npar ndex = i*(i-1)/2 do 7 j=1,i-1 ndex = ndex + 1 7 vhmat(ndex) = 0. ndex = ndex + 1 if (g2(i) .le. zero) g2(i) = 1. vhmat(ndex) = 2./g2(i) 8 continue dcovar = 1. if (ldebug) write (isyswr,'(a,a/(1x,10g10.2))') ' debug mnmigr,', + ' starting matrix diagonal, vhmat=', (vhmat(kk),kk=1,int(vlen)) c ready to start first iteration 10 continue impruv = 0 nrstrt = nrstrt + 1 if (nrstrt .gt. istrat+1) then cstatu= 'failed ' go to 230 endif fs = amin c . . . get edm and set up loop edm = 0. do 18 i= 1, npar gs(i) = grd(i) xxs(i) = x(i) ndex = i*(i-1)/2 do 17 j= 1, i-1 ndex = ndex + 1 17 edm = edm + gs(i)*vhmat(ndex)*gs(j) ndex = ndex + 1 18 edm = edm + 0.5 * gs(i)**2 *vhmat(ndex) edm = edm * 0.5 * (1.0+3.0*dcovar) if (edm .lt. zero) then call mnwarn('w','migrad','starting matrix not pos-definite.') isw(2) = 0 dcovar = 1. go to 2 endif if (isw(2) .eq. 0) edm=bigedm iter = 0 call mninex(x) call mnwerr if (iswtr .ge. 1) call mnprin(3,amin) if (iswtr .ge. 2) call mnmatu(0) c . . . . . start main loop 24 continue if (nfcn-npfn .ge. nfcnmx) go to 190 gdel = 0. gssq = 0. do 30 i=1,npar ri = 0. gssq = gssq + gs(i)**2 do 25 j=1,npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n 25 ri = ri + vhmat(ndex) *gs(j) step(i) = -0.5*ri 30 gdel = gdel + step(i)*gs(i) if (gssq .eq. zero) then call mnwarn('d','migrad', + ' first derivatives of fcn are all zero') go to 300 endif c if gdel positive, v not posdef if (gdel .ge. zero) then call mnwarn('d','migrad',' newton step not descent.') if (npsdf .eq. 1) go to 1 call mnpsdf npsdf = 1 go to 24 endif c . . . . do line search call mnline(fcn,xxs,fs,step,gdel,toler,futil) if (amin .eq. fs) go to 200 cfrom = 'migrad ' nfcnfr = nfcnmg cstatu= 'progress ' c . get gradient at new point call mninex(x) if (isw(3) .eq. 1) then call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 endif call mnderi(fcn,futil) c . calculate new edm npsdf = 0 81 edm = 0. gvg = 0. delgam = 0. gdgssq = 0. do 100 i= 1, npar ri = 0. vgi = 0. do 90 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n vgi = vgi + vhmat(ndex)*(grd(j)-gs(j)) 90 ri = ri + vhmat(ndex)* grd(j) vg(i) = vgi*0.5 gami = grd(i) - gs(i) gdgssq = gdgssq + gami**2 gvg = gvg + gami*vg(i) delgam = delgam + dirin(i)*gami 100 edm = edm + grd(i)*ri*0.5 edm = edm * 0.5 * (1.0 + 3.0*dcovar) c . if edm negative, not positive-definite if (edm .lt. zero .or. gvg .le. zero) then call mnwarn('d','migrad','not pos-def. edm or gvg negative.') cstatu = 'not posdef' if (npsdf .eq. 1) go to 230 call mnpsdf npsdf = 1 go to 81 endif c print information about this iteration iter = iter + 1 if (iswtr.ge.3 .or. (iswtr.eq.2.and.mod(iter,10).eq.1)) then call mnwerr call mnprin(3,amin) endif if (gdgssq .eq. zero) call mnwarn('d','migrad', + 'no change in first derivatives over last step') if (delgam .lt. zero) call mnwarn('d','migrad', + 'first derivatives increasing along search line') c . update covariance matrix cstatu = 'improvemnt' if (ldebug) write (isyswr,'(a,(1x,10g10.3))') ' vhmat 1 =', + (vhmat(kk),kk=1,10) dsum = 0. vsum = 0. do 120 i=1, npar do 120 j=1, i d = dirin(i)*dirin(j)/delgam - vg(i)*vg(j)/gvg dsum = dsum + abs(d) ndex = i*(i-1)/2 + j vhmat(ndex) = vhmat(ndex) + 2.0*d vsum = vsum + abs(vhmat(ndex)) 120 continue c smooth local fluctuations by averaging dcovar dcovar = 0.5*(dcovar + dsum/vsum) if (iswtr.ge.3 .or. ldebug) write (isyswr,'(a,f5.1,a)') + ' relative change in cov. matrix=',dcovar*100.,'%' if (ldebug) write (isyswr,'(a,(1x,10g10.3))') ' vhmat 2 =', + (vhmat(kk),kk=1,10) if (delgam .le. gvg) go to 135 do 125 i= 1, npar 125 flnu(i) = dirin(i)/delgam - vg(i)/gvg do 130 i= 1, npar do 130 j= 1, i ndex = i*(i-1)/2 + j 130 vhmat(ndex) = vhmat(ndex) + 2.0*gvg*flnu(i)*flnu(j) 135 continue c and see if converged if (edm .lt. 0.1*rhotol) go to 300 c if not, prepare next iteration do 140 i= 1, npar xxs(i) = x(i) gs(i) = grd(i) 140 continue fs = amin impruv = impruv + 1 if (isw(2) .eq. 0 .and. dcovar.lt. 0.5 ) isw(2) = 1 if (isw(2) .eq. 3 .and. dcovar.gt. 0.1 ) isw(2) = 1 if (isw(2) .eq. 1 .and. dcovar.lt. 0.05) isw(2) = 3 go to 24 c . . . . . end main loop c . . call limit in mnmigr 190 isw(1) = 1 if (isw(5) .ge. 0) + write (isyswr,'(a)') ' call limit exceeded in migrad.' cstatu = 'call limit' go to 230 c . . fails to improve . . 200 if (iswtr .ge. 1) write (isyswr,'(a)') + ' migrad fails to find improvement' do 210 i= 1, npar 210 x(i) = xxs(i) if (edm .lt. rhotol) go to 300 if (edm .lt. abs(epsma2*amin)) then if (iswtr .ge. 0) write (isyswr, '(a)') + ' machine accuracy limits further improvement.' go to 300 endif if (istrat .lt. 1) then if (isw(5) .ge. 0) write (isyswr, '(a)') + ' migrad fails with strategy=0. will try with strategy=1.' istrat = 1 endif go to 1 c . . fails to converge 230 if (iswtr .ge. 0) write (isyswr,'(a)') + ' migrad terminated without convergence.' if (isw(2) .eq. 3) isw(2) = 1 isw(4) = -1 go to 400 c . . apparent convergence 300 if (iswtr .ge. 0) write(isyswr,'(/a)') + ' migrad minimization has converged.' if (itaur .eq. 0) then if (istrat .ge. 2 .or. (istrat.eq.1.and.isw(2).lt.3)) then if (isw(5) .ge. 0) write (isyswr, '(/a)') + ' migrad will verify convergence and error matrix.' call mnhess(fcn,futil) call mnwerr npsdf = 0 if (edm .gt. rhotol) go to 10 endif endif cstatu='converged ' isw(4) = 1 c come here in any case 400 continue cfrom = 'migrad ' nfcnfr = nfcnmg call mninex(x) call mnwerr if (iswtr .ge. 0) call mnprin (3,amin) if (iswtr .ge. 1) call mnmatu(1) return end cdeck id>, mnmnos. subroutine mnmnos(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minos error analysis on those parameters for cc which it is requested on the minos command. cc 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 if (npar .le. 0) go to 700 ngood = 0 nbad = 0 nfcnmi = nfcn c . loop over parameters requested do 570 knt= 1, npar if (int(word7(2)) .eq. 0) then ilax = nexofi(knt) else if (knt .ge. 7) go to 580 ilax = int(word7(knt+1)) if (ilax .eq. 0) go to 580 if (ilax .gt. 0 .and. ilax .le. nu) then if (niofex(ilax) .gt. 0) go to 565 endif write (isyswr,564) ilax 564 format (' parameter number ',i5,' not variable. ignored.') go to 570 endif 565 continue c calculate one pair of m e's ilax2 = 0 call mnmnot(fcn,ilax,ilax2,val2pl,val2mi,futil) if (lnewmn) go to 650 c update ngood and nbad iin = niofex(ilax) if (erp(iin) .gt. zero) then ngood=ngood+1 else nbad=nbad+1 endif if (ern(iin) .lt. zero) then ngood=ngood+1 else nbad=nbad+1 endif 570 continue c end of loop . . . . . . . 580 continue c . . . . printout final values . cfrom = 'minos ' nfcnfr = nfcnmi cstatu= 'unchanged ' if (ngood.eq.0.and.nbad.eq.0) go to 700 if (ngood.gt.0.and.nbad.eq.0) cstatu='successful' if (ngood.eq.0.and.nbad.gt.0) cstatu='failure ' if (ngood.gt.0.and.nbad.gt.0) cstatu='problems ' if (isw(5) .ge. 0) call mnprin(4,amin) if (isw(5) .ge. 2) call mnmatu(0) go to 900 c . . . new minimum found . . . . 650 continue cfrom = 'minos ' nfcnfr = nfcnmi cstatu= 'new minimu' if (isw(5) .ge. 0) call mnprin(4,amin) write (isyswr,675) 675 format(/50h new minimum found. go back to minimization step./1h , +60(1h=)/60x,1hv/60x,1hv/60x,1hv/57x,7hvvvvvvv/58x,5hvvvvv/59x, +3hvvv/60x,1hv//) go to 900 700 write (isyswr,'(a)') ' there are no minos errors to calculate.' 900 return end cdeck id>, mnmnot. subroutine mnmnot(fcn,ilax,ilax2,val2pl,val2mi,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minos error analysis on one parameter. cc the parameter ilax is varied, and the minimum of the cc function with respect to the other parameters is followed cc until it crosses the value fmin+up. cc 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 dimension xdev(mni),w(mni),gcc(mni) character*4 cpos,cneg,csig character*1 cdot,cstar,cblank parameter (cpos='posi',cneg='nega',cdot='.',cstar='*',cblank=' ') logical lovflo, lright, lleft c . . save and prepare start vals isw2 = isw(2) isw4 = isw(4) sigsav = edm istrav = istrat dc = dcovar lovflo = .false. lnewmn = .false. toler = epsi*0.5 apsi = epsi*0.5 abest=amin aim = amin + up mpar=npar nfmxin = nfcnmx do 125 i= 1, mpar 125 xt(i) = x(i) do 130 j= 1, mpar*(mpar+1)/2 130 vthmat(j) = vhmat(j) do 135 i= 1, mpar gcc(i) = globcc(i) 135 w(i) = werr(i) it = niofex(ilax) erp(it) = 0. ern(it) = 0. call mninex(xt) ut = u(ilax) if (nvarl(ilax) .eq. 1) then alim(ilax) = ut -100.*w(it) blim(ilax) = ut +100.*w(it) endif ndex = it*(it+1)/2 xunit = dsqrt(up/vthmat(ndex)) marc = 0 do 162 i= 1, mpar if (i .eq. it) go to 162 marc = marc + 1 imax = max(it,i) indx = imax*(imax-1)/2 + min(it,i) xdev(marc) = xunit*vthmat(indx) 162 continue c fix the parameter in question call mnfixp (it,ierr) if (ierr .gt. 0) then write (isyswr,'(a,i5,a,i5)') + ' minuit error. cannot fix parameter',ilax,' internal',it go to 700 endif c . . . . . nota bene: from here on, npar=mpar-1 c remember: mnfixp squeezes it out of x, xt, werr, and vhmat, c not w, vthmat do 500 isig= 1,2 if (isig .eq. 1) then sig = 1.0 csig = cpos else sig = -1.0 csig = cneg endif c . sig=sign of error being calcd if (isw(5) .gt. 1) write (isyswr,806) csig,ilax,cpnam(ilax) 806 format (/' determination of ',a4,'tive minos error for parameter', + i3, 2x ,a) if (isw(2).le.0) call mnwarn('d','minos','no covariance matrix.') nlimit = nfcn + nfmxin istrat = max(istrav-1,0) du1 = w(it) u(ilax) = ut + sig*du1 fac = sig*du1/w(it) do 185 i= 1, npar 185 x(i) = xt(i) + fac*xdev(i) if (isw(5) .gt. 1) write (isyswr,801) ilax,ut,sig*du1,u(ilax) 801 format (/' parameter',i4,' set to',e11.3,' + ',e10.3,' = ',e12.3) c loop to hit aim ke1cr = ilax ke2cr = 0 xmidcr = ut + sig*du1 xdircr = sig*du1 c amin = abest nfcnmx = nlimit - nfcn call mncros(fcn,aopt,iercr,futil) if (abest-amin .gt. 0.01*up) go to 650 if (iercr .eq. 1) go to 440 if (iercr .eq. 2) go to 450 if (iercr .eq. 3) go to 460 c . error successfully calculated eros = sig*du1 + aopt*xdircr if (isw(5) .gt. 1) write (isyswr,808) csig,ilax,cpnam(ilax),eros 808 format (/9x,4hthe ,a4, 29htive minos error of parameter,i3, 2h +, ,a10, 4h, is ,e12.4) go to 480 c . . . . . . . . failure returns 440 if (isw(5) .ge. 1) write(isyswr,807) csig,ilax,cpnam(ilax) 807 format (5x,'the ',a4,'tive minos error of parameter',i3,', ',a, +', exceeds its limit.'/) eros = undefi go to 480 450 if (isw(5) .ge. 1) write (isyswr, 802) csig,ilax,nfmxin 802 format (9x,'the ',a,'tive minos error',i4,' requires more than', + i5,' function calls.'/) eros = 0. go to 480 460 if (isw(5) .ge. 1) write (isyswr, 805) csig,ilax 805 format (25x,a,'tive minos error not calculated for parameter',i4/) eros = 0. c 480 if (isw(5) .gt. 1) write (isyswr,'(5x, 74(1h*))') if (sig .lt. zero) then ern(it) = eros if (ilax2.gt.0 .and. ilax2.le.nu) val2mi = u(ilax2) else erp(it) = eros if (ilax2.gt.0 .and. ilax2.le.nu) val2pl = u(ilax2) endif 500 continue c . . parameter finished. reset v c normal termination itaur = 1 call mnfree(1) do 550 j= 1, mpar*(mpar+1)/2 550 vhmat(j) = vthmat(j) do 595 i= 1, mpar werr(i) = w(i) globcc(i) = gcc(i) 595 x(i) = xt(i) call mninex (x) edm = sigsav amin = abest isw(2) = isw2 isw(4) = isw4 dcovar = dc go to 700 c new minimum 650 lnewmn = .true. isw(2) = 0 dcovar = 1. isw(4) = 0 sav = u(ilax) itaur = 1 call mnfree(1) u(ilax) = sav call mnexin(x) edm = bigedm c in any case 700 continue itaur = 0 nfcnmx = nfmxin istrat = istrav return end cdeck id>, mnparm. subroutine mnparm(k,cnamj,uk,wk,a,b,ierflg) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnread and user-callable cc implements one parameter definition, that is: cc k (external) parameter number cc cnamk parameter name cc uk starting value cc wk starting step size or uncertainty cc a, b lower and upper physical parameter limits cc and sets up (updates) the parameter lists. cc output: ierflg=0 if no problems cc >0 if mnparm unable to implement definition cc 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 character*(*) cnamj character cnamk*10, chbufi*4 c cnamk = cnamj kint = npar if (k.lt.1 .or. k.gt.maxext) then c parameter number exceeds allowed maximum value write (isyswr,9) k,maxext 9 format (/' minuit user error. parameter number is',i11/ + ', allowed range is one to',i4/) go to 800 endif c normal parameter request ktofix = 0 if (nvarl(k) .lt. 0) go to 50 c previously defined parameter is being redefined c find if parameter was fixed do 40 ix= 1, npfix if (ipfix(ix) .eq. k) ktofix = k 40 continue if (ktofix .gt. 0) then call mnwarn('w','param def','redefining a fixed parameter.') if (kint .ge. maxint) then write (isyswr,'(a)') ' cannot release. max npar exceeded.' go to 800 endif call mnfree(-k) endif c if redefining previously variable parameter if(niofex(k) .gt. 0) kint = npar-1 50 continue c c . . .print heading if (lphead .and. isw(5).ge.0) then write (isyswr,61) lphead = .false. endif 61 format(/' parameter definitions:'/ + ' no. name value step size limits') if (wk .gt. zero) go to 122 c . . .constant parameter . . . . if (isw(5) .ge. 0) write (isyswr, 82) k,cnamk,uk 82 format (1x,i5,1x,1h',a10,1h',1x,g13.5, ' constant') nvl = 0 go to 200 122 if (a.eq.zero .and. b.eq.zero) then c variable parameter without limits nvl = 1 if (isw(5) .ge. 0) write (isyswr, 127) k,cnamk,uk,wk 127 format (1x,i5,1x,1h',a10,1h',1x,2g13.5, ' no limits') else c variable parameter with limits nvl = 4 lnolim = .false. if (isw(5) .ge. 0) write (isyswr, 132) k,cnamk,uk,wk,a,b 132 format(1x,i5,1x,1h',a10,1h',1x,2g13.5,2x,2g13.5) endif c . . request for another variable parameter kint = kint + 1 if (kint .gt. maxint) then write (isyswr,135) maxint 135 format (/' minuit user error. too many variable parameters.'/ + ' this version of minuit dimensioned for',i4//) go to 800 endif if (nvl .eq. 1) go to 200 if (a .eq. b) then write (isyswr,'(/a,a/a/)') ' user error in minuit parameter', + ' definition',' upper and lower limits equal.' go to 800 endif if (b .lt. a) then sav = b b = a a = sav call mnwarn('w','param def','parameter limits were reversed.') if (lwarn) lphead=.true. endif if ((b-a) .gt. 1.0e7) then write (chbufi,'(i4)') k call mnwarn('w','param def', + 'limits on param'//chbufi//' too far apart.') if (lwarn) lphead=.true. endif danger = (b-uk)*(uk-a) if (danger .lt. 0.) + call mnwarn('w','param def','starting value outside limits.') if (danger .eq. 0.) + call mnwarn('w','param def','starting value is at limit.') 200 continue c . . . input ok, set values, arrange lists, c calculate step sizes gstep, dirin cfrom = 'parametr' nfcnfr = nfcn cstatu= 'new values' nu = max(nu,k) cpnam(k) = cnamk u(k) = uk alim(k) = a blim(k) = b nvarl(k) = nvl call mnrset(1) c k is external number of new parameter c lastin is the number of var. params with ext. param. no.< k lastin = 0 do 240 ix= 1, k-1 if (niofex(ix) .gt. 0) lastin=lastin+1 240 continue c kint is new number of variable params, npar is old if (kint .eq. npar) go to 280 if (kint .gt. npar) then c insert new variable parameter in list do 260 in= npar,lastin+1,-1 ix = nexofi(in) niofex(ix) = in+1 nexofi(in+1)= ix x (in+1) = x (in) xt (in+1) = xt (in) dirin(in+1) = dirin(in) g2 (in+1) = g2 (in) gstep(in+1) = gstep(in) 260 continue else c remove variable parameter from list do 270 in= lastin+1,kint ix = nexofi(in+1) niofex(ix) = in nexofi(in)= ix x (in)= x (in+1) xt (in)= xt (in+1) dirin (in)= dirin(in+1) g2 (in)= g2 (in+1) gstep (in)= gstep(in+1) 270 continue endif 280 continue ix = k niofex(ix) = 0 npar = kint c lists are now arranged . . . . if (nvl .gt. 0) then in = lastin+1 nexofi(in) = ix niofex(ix) = in sav = u(ix) call mnpint(sav,ix,pinti) x(in) = pinti xt(in) = x(in) werr(in) = wk sav2 = sav + wk call mnpint(sav2,ix,pinti) vplu = pinti - x(in) sav2 = sav - wk call mnpint(sav2,ix,pinti) vminu = pinti - x(in) dirin(in) = 0.5 * (abs(vplu) +abs(vminu)) g2(in) = 2.0*up / dirin(in)**2 gsmin = 8.*epsma2*abs(x(in)) gstep(in) = max (gsmin, 0.1*dirin(in)) if (amin .ne. undefi) then small = dsqrt(epsma2*(amin+up)/up) gstep(in) = max(gsmin, small*dirin(in)) endif grd (in) = g2(in)*dirin(in) c if parameter has limits if (nvarl(k) .gt. 1) then if (gstep(in).gt. 0.5) gstep(in)=0.5 gstep(in) = -gstep(in) endif endif if (ktofix .gt. 0) then kinfix = niofex(ktofix) if (kinfix .gt. 0) call mnfixp(kinfix,ierr) if (ierr .gt. 0) go to 800 endif ierflg = 0 return c error on input, unable to implement request . . . . 800 continue ierflg = 1 return end cdeck id>, mnpfit. subroutine mnpfit(parx2p,pary2p,npar2p,coef2p,sdev2p) c ************ double precision version ************* implicit double precision (a-h,o-z) c c to fit a parabola to npar2p points c c npar2p no. of points c parx2p(i) x value of point i c pary2p(i) y value of point i c c coef2p(1...3) coefficients of the fitted parabola c y=coef2p(1) + coef2p(2)*x + coef2p(3)*x**2 c sdev2p= variance c method : chi**2 = min equation solved explicitly dimension parx2p(npar2p),pary2p(npar2p),coef2p(npar2p) dimension cz(3) c do 3 i=1,3 3 cz(i)=0. sdev2p=0. if(npar2p.lt.3) go to 10 f=npar2p c--- center x values for reasons of machine precision xm=0. do 2 i=1,npar2p 2 xm=xm+parx2p(i) xm=xm/f x2=0. x3=0. x4=0. y=0. y2=0. xy=0. x2y=0. do 1 i=1,npar2p s=parx2p(i)-xm t=pary2p(i) s2=s*s x2=x2+s2 x3=x3+s*s2 x4=x4+s2*s2 y=y+t y2=y2+t*t xy=xy+s*t x2y=x2y+s2*t 1 continue a=(f*x4-x2**2)*x2-f*x3**2 if(a.eq.0.) goto 10 cz(3)=(x2*(f*x2y-x2*y)-f*x3*xy)/a cz(2)=(xy-x3*cz(3))/x2 cz(1)=(y-x2*cz(3))/f if(npar2p.eq.3) goto 6 sdev2p=y2-(cz(1)*y+cz(2)*xy+cz(3)*x2y) if(sdev2p.lt.0.) sdev2p=0. sdev2p=sdev2p/(f-3.) 6 cz(1)=cz(1)+xm*(xm*cz(3)-cz(2)) cz(2)=cz(2)-2.*xm*cz(3) 10 continue do 11 i=1,3 11 coef2p(i)=cz(i) return end cdeck id>, mnpint. subroutine mnpint(pexti,i,pinti) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the internal parameter value pinti corresponding cc to the external value pexti for parameter i. cc 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 logical limloc character chbufi*4, chbuf2*30 limloc = .false. pinti = pexti igo = nvarl(i) if (igo .eq. 4) then c-- there are two limits alimi = alim(i) blimi = blim(i) yy=2.0*(pexti-alimi)/(blimi-alimi) - 1.0 yy2 = yy**2 if (yy2 .ge. (1.0- epsma2)) then if (yy .lt. 0.) then a = vlimlo chbuf2 = ' is at its lower allowed limit.' else a = vlimhi chbuf2 = ' is at its upper allowed limit.' endif pinti = a pexti = alimi + 0.5* (blimi-alimi) *(dsin(a) +1.0) limset = .true. write (chbufi,'(i4)') i if (yy2 .gt. 1.0) chbuf2 = ' brought back inside limits.' call mnwarn('w',cfrom,'variable'//chbufi//chbuf2) else pinti = dasin(yy) endif endif return end cdeck id>, mnplot. subroutine mnplot(xpt,ypt,chpt,nxypt,nunit,npagwd,npagln) c ************ double precision version ************* implicit double precision (a-h,o-z) cc plots points in array xypt onto one page with labelled axes cc nxypt is the number of points to be plotted cc xpt(i) = x-coord. of ith point cc ypt(i) = y-coord. of ith point cc chpt(i) = character to be plotted at this position cc the input point arrays xpt, ypt, chpt are destroyed. cc dimension xpt(*), ypt(*), sav(2) character*1 chpt(*) , chsav, chbest, cdot, cslash, cblank parameter (maxwid=100) character cline*100, chmess*30 dimension xvalus(12) logical overpr data cdot,cslash,cblank/ '.' , '/' , ' '/ maxnx = min(npagwd-20,maxwid) if (maxnx .lt. 10) maxnx = 10 maxny = npagln if (maxny .lt. 10) maxny = 10 if (nxypt .le. 1) return xbest = xpt(1) ybest = ypt(1) chbest = chpt(1) c order the points by decreasing y km1 = nxypt - 1 do 150 i= 1, km1 iquit = 0 ni = nxypt - i do 140 j= 1, ni if (ypt(j) .gt. ypt(j+1)) go to 140 savx = xpt(j) xpt(j) = xpt(j+1) xpt(j+1) = savx savy = ypt(j) ypt(j) = ypt(j+1) ypt(j+1) = savy chsav = chpt(j) chpt(j) = chpt(j+1) chpt(j+1) = chsav iquit = 1 140 continue if (iquit .eq. 0) go to 160 150 continue 160 continue c find extreme values xmax = xpt(1) xmin = xmax do 200 i= 1, nxypt if (xpt(i) .gt. xmax) xmax = xpt(i) if (xpt(i) .lt. xmin) xmin = xpt(i) 200 continue dxx = 0.001*(xmax-xmin) xmax = xmax + dxx xmin = xmin - dxx call mnbins(xmin,xmax,maxnx,xmin,xmax,nx,bwidx) ymax = ypt(1) ymin = ypt(nxypt) if (ymax .eq. ymin) ymax=ymin+1.0 dyy = 0.001*(ymax-ymin) ymax = ymax + dyy ymin = ymin - dyy call mnbins(ymin,ymax,maxny,ymin,ymax,ny,bwidy) any = ny c if first point is blank, it is an 'origin' if (chbest .eq. cblank) go to 50 xbest = 0.5 * (xmax+xmin) ybest = 0.5 * (ymax+ymin) 50 continue c find scale constants ax = 1.0/bwidx ay = 1.0/bwidy bx = -ax*xmin + 2.0 by = -ay*ymin - 2.0 c convert points to grid positions do 300 i= 1, nxypt xpt(i) = ax*xpt(i) + bx 300 ypt(i) = any-ay*ypt(i) - by nxbest = ax*xbest + bx nybest = any - ay*ybest - by c print the points ny = ny + 2 nx = nx + 2 isp1 = 1 linodd = 1 overpr=.false. do 400 i= 1, ny do 310 ibk= 1, nx 310 cline (ibk:ibk) = cblank cline(1:1) = cdot cline(nx:nx) = cdot cline(nxbest:nxbest) = cdot if (i.ne.1 .and. i.ne.nybest .and. i.ne.ny) go to 320 do 315 j= 1, nx 315 cline(j:j) = cdot 320 continue yprt = ymax - float(i-1)*bwidy if (isp1 .gt. nxypt) go to 350 c find the points to be plotted on this line do 341 k= isp1,nxypt ks = ypt(k) if (ks .gt. i) go to 345 ix = xpt(k) if (cline(ix:ix) .eq. cdot) go to 340 if (cline(ix:ix) .eq. cblank) go to 340 if (cline(ix:ix) .eq.chpt(k)) go to 341 overpr = .true. c overpr is true if one or more positions contains more than c one point cline(ix:ix) = '&' go to 341 340 cline(ix:ix) = chpt(k) 341 continue isp1 = nxypt + 1 go to 350 345 isp1 = k 350 continue if (linodd .eq. 1 .or. i .eq. ny) go to 380 linodd = 1 write (nunit, '(18x,a)') cline(:nx) go to 400 380 write (nunit,'(1x,g14.7,a,a)') yprt, ' ..', cline(:nx) linodd = 0 400 continue c print labels on x-axis every ten columns do 410 ibk= 1, nx cline(ibk:ibk) = cblank if (mod(ibk,10) .eq. 1) cline(ibk:ibk) = cslash 410 continue write (nunit, '(18x,a)') cline(:nx) c do 430 ibk= 1, 12 430 xvalus(ibk) = xmin + float(ibk-1)*10.*bwidx iten = (nx+9) / 10 write (nunit,'(12x,12g10.4)') (xvalus(ibk), ibk=1,iten) chmess = ' ' if (overpr) chmess=' overprint character is &' write (nunit,'(25x,a,g13.7,a)') 'one column=',bwidx, chmess 500 return end cdeck id>, mnpout. subroutine mnpout(iuext,chnam,val,err,xlolim,xuplim,iuint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc user-called cc provides the user with information concerning the current status cc of parameter number iuext. namely, it returns: cc chnam: the name of the parameter cc val: the current (external) value of the parameter cc err: the current estimate of the parameter uncertainty cc xlolim: the lower bound (or zero if no limits) cc xuplim: the upper bound (or zero if no limits) cc iuint: the internal parameter number (or zero if not variable, cc or negative if undefined). cc note also: if iuext is negative, then it is -internal parameter cc number, and iuint is returned as the external number. cc except for iuint, this is exactly the inverse of mnparm cc 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 character*(*) chnam xlolim = 0. xuplim = 0. err = 0. if (iuext .eq. 0) go to 100 if (iuext .lt. 0) then c internal parameter number specified iint = -iuext if (iint .gt. npar) go to 100 iext = nexofi(iint) iuint = iext else c external parameter number specified iext = iuext if (iext .eq. 0) go to 100 if (iext .gt. nu) go to 100 iint = niofex(iext) iuint = iint endif c in both cases nvl = nvarl(iext) if (nvl .lt. 0) go to 100 chnam = cpnam(iext) val = u(iext) if (iint .gt. 0) err = werr(iint) if (nvl .eq. 4) then xlolim = alim(iext) xuplim = blim(iext) endif return c parameter is undefined 100 iuint = -1 chnam = 'undefined' val = 0. return end cdeck id>, mnprin. subroutine mnprin (inkode,fval) c ************ double precision version ************* implicit double precision (a-h,o-z) cc prints the values of the parameters at the time of the call. cc also prints other relevant information such as function value, cc estimated distance to minimum, parameter errors, step sizes. cc c according to the value of ikode, the printout is: c ikode=inkode= 0 only info about function value c 1 parameter values, errors, limits c 2 values, errors, step sizes, internal values c 3 values, errors, step sizes, first derivs. c 4 values, parabolic errors, minos errors c when inkode=5, mnprin chooses ikode=1,2, or 3, according to isw(2) c 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 c character*14 colhdu(6),colhdl(6), cx2,cx3,cgetx character*11 cnambf, cblank character chedm*10, cheval*15 parameter (cgetx='please get x..') data cblank/' '/ c if (nu .eq. 0) then write (isyswr,'(a)') ' there are currently no parameters defined' go to 700 endif c get value of ikode based in inkode, isw(2) ikode = inkode if (inkode .eq. 5) then ikode = isw(2)+1 if (ikode .gt. 3) ikode=3 endif c set 'default' column headings do 5 k= 1, 6 colhdu(k) = 'undefined' 5 colhdl(k) = 'column head' c print title if minos errors, and title exists. if (ikode.eq.4 .and. ctitl.ne.cundef) + write (isyswr,'(/a,a)') ' minuit task: ',ctitl c report function value and status if (fval .eq. undefi) then cheval = ' unknown ' else write (cheval,'(g15.7)') fval endif if (edm .eq. bigedm) then chedm = ' unknown ' else write (chedm, '(e10.2)') edm endif nc = nfcn-nfcnfr write (isyswr,905) cheval,cfrom,cstatu,nc,nfcn 905 format (/' fcn=',a,' from ',a8,' status=',a10,i6,' calls', + i9,' total') m = isw(2) if (m.eq.0 .or. m.eq.2 .or. dcovar.eq.zero) then write (isyswr,907) chedm,istrat,covmes(m) 907 format (21x,'edm=',a,' strategy=',i2,6x,a) else dcmax = 1. dc = min(dcovar,dcmax) * 100. write (isyswr,908) chedm,istrat,dc 908 format (21x,'edm=',a,' strategy=',i1,' error matrix', + ' uncertainty=',f5.1,'%') endif c if (ikode .eq. 0) go to 700 c find longest name (for rene!) ntrail = 10 do 20 i= 1, nu if (nvarl(i) .lt. 0) go to 20 do 15 ic= 10,1,-1 if (cpnam(i)(ic:ic) .ne. ' ') go to 16 15 continue ic = 1 16 lbl = 10-ic if (lbl .lt. ntrail) ntrail=lbl 20 continue nadd = ntrail/2 + 1 if (ikode .eq. 1) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' physical' colhdu(3) = ' limits ' colhdl(2) = ' negative ' colhdl(3) = ' positive ' endif if (ikode .eq. 2) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' internal ' colhdl(2) = ' step size ' colhdu(3) = ' internal ' colhdl(3) = ' value ' endif if (ikode .eq. 3) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' step ' colhdl(2) = ' size ' colhdu(3) = ' first ' colhdl(3) = ' derivative ' endif if (ikode .eq. 4) then colhdu(1) = ' parabolic ' colhdl(1) = ' error ' colhdu(2) = ' minos ' colhdu(3) = 'errors ' colhdl(2) = ' negative ' colhdl(3) = ' positive ' endif c if (ikode .ne. 4) then if (isw(2) .lt. 3) colhdu(1)=' approximate ' if (isw(2) .lt. 1) colhdu(1)=' current guess' endif ncol = 3 write (isyswr, 910) (colhdu(kk),kk=1,ncol) write (isyswr, 911) (colhdl(kk),kk=1,ncol) 910 format (/' ext parameter ', 13x ,6a14) 911 format ( ' no. name ',' value ',6a14) c c . . . loop over parameters . . do 200 i= 1, nu if (nvarl(i) .lt. 0) go to 200 l = niofex(i) cnambf = cblank(1:nadd)//cpnam(i) if (l .eq. 0) go to 55 c variable parameter. x1 = werr(l) cx2 = cgetx cx3 = cgetx if (ikode .eq. 1) then if (nvarl(i) .le. 1) then write (isyswr, 952) i,cnambf,u(i),x1 go to 200 else x2 = alim(i) x3 = blim(i) endif endif if (ikode .eq. 2) then x2 = dirin(l) x3 = x(l) endif if (ikode .eq. 3) then x2 = dirin(l) x3 = grd(l) if (nvarl(i).gt.1 .and. abs(dcos(x(l))) .lt. 0.001) + cx3 = '** at limit **' endif if (ikode .eq. 4) then x2 = ern(l) if (x2.eq.zero) cx2=' ' if (x2.eq.undefi) cx2=' at limit ' x3 = erp(l) if (x3.eq.zero) cx3=' ' if (x3.eq.undefi) cx3=' at limit ' endif if (cx2.eq.cgetx) write (cx2,'(g14.5)') x2 if (cx3.eq.cgetx) write (cx3,'(g14.5)') x3 write (isyswr,952) i,cnambf,u(i),x1,cx2,cx3 952 format (i4,1x,a11,2g14.5,2a) c check if parameter is at limit if (nvarl(i) .le. 1 .or. ikode .eq. 3) go to 200 if (abs(dcos(x(l))) .lt. 0.001) write (isyswr,1004) 1004 format (1h ,32x,42hwarning - - above parameter is at limit.) go to 200 c c print constant or fixed parameter. 55 continue colhdu(1) = ' constant ' if (nvarl(i).gt.0) colhdu(1) = ' fixed ' if (nvarl(i).eq.4 .and. ikode.eq.1) then write (isyswr,'(i4,1x,a11,g14.5,a,2g14.5)') + i,cnambf,u(i),colhdu(1),alim(i),blim(i) else write (isyswr,'(i4,1x,a11,g14.5,a)') i,cnambf,u(i),colhdu(1) endif 200 continue c if (up.ne.updflt) write (isyswr,'(31x,a,g10.2)') 'err def=',up 700 continue return end cdeck id>, mnpsdf. subroutine mnpsdf c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the eigenvalues of v to see if positive-def. cc if not, adds constant along diagonal to make positive. 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 character chbuff*12 dimension s(mni) epsmin = 1.0e-6 epspdf = max(epsmin, epsma2) dgmin = vhmat(1) c check if negative or zero on diagonal do 200 i= 1, npar ndex = i*(i+1)/2 if (vhmat(ndex) .le. zero) then write (chbuff(1:3),'(i3)') i call mnwarn('w',cfrom, +'negative diagonal element'//chbuff(1:3)//' in error matrix') endif if (vhmat(ndex) .lt. dgmin) dgmin = vhmat(ndex) 200 continue if (dgmin .le. 0.) then dg = 1.0 - dgmin write (chbuff,'(e12.2)') dg call mnwarn('w',cfrom, + chbuff//' added to diagonal of error matrix') else dg = 0. endif c store vhmat in p, make sure diagonal pos. do 213 i= 1, npar ndex = i*(i-1)/2 ndexd = ndex + i vhmat(ndexd) = vhmat(ndexd) + dg s(i) = 1.0/dsqrt(vhmat(ndexd)) do 213 j= 1, i ndex = ndex + 1 213 p(i,j) = vhmat(ndex) * s(i)*s(j) c call eigen (p,p,maxint,npar,pstar,-npar) call mneig(p,maxint,npar,maxint,pstar,epspdf,ifault) pmin = pstar(1) pmax = pstar(1) do 215 ip= 2, npar if (pstar(ip) .lt. pmin) pmin = pstar(ip) if (pstar(ip) .gt. pmax) pmax = pstar(ip) 215 continue pmax = max(abs(pmax), one) if ((pmin .le. zero .and. lwarn) .or. isw(5) .ge. 2) then write (isyswr,550) write (isyswr,551) (pstar(ip),ip=1,npar) endif if (pmin .gt. epspdf*pmax) go to 217 if (isw(2) .eq. 3) isw(2)=2 padd = 1.0e-3*pmax - pmin do 216 ip= 1, npar ndex = ip*(ip+1)/2 216 vhmat(ndex) = vhmat(ndex) *(1.0 + padd) cstatu= 'not posdef' write (chbuff,'(g12.5)') padd call mnwarn('w',cfrom, + 'matrix forced pos-def by adding '//chbuff//' to diagonal.') 217 continue c 550 format (' eigenvalues of second-derivative matrix:' ) 551 format (7x,6e12.4) return end cdeck id>, mnrazz. subroutine mnrazz(ynew,pnew,y,jh,jl) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called only by mnsimp (and mnimpr) to add a new point cc and remove an old one from the current simplex, and get the cc estimated distance to minimum. cc 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 dimension pnew(*), y(*) do 10 i=1,npar 10 p(i,jh) = pnew(i) y(jh)=ynew if(ynew .lt. amin) then do 15 i=1,npar 15 x(i) = pnew(i) call mninex(x) amin = ynew cstatu = 'progress ' jl=jh endif jh = 1 nparp1 = npar+1 20 do 25 j=2,nparp1 if (y(j) .gt. y(jh)) jh = j 25 continue edm = y(jh) - y(jl) if (edm .le. zero) go to 45 us = 1.0/edm do 35 i= 1, npar pbig = p(i,1) plit = pbig do 30 j= 2, nparp1 if (p(i,j) .gt. pbig) pbig = p(i,j) if (p(i,j) .lt. plit) plit = p(i,j) 30 continue dirin(i) = pbig - plit 35 continue 40 return 45 write (isyswr, 1000) npar go to 40 1000 format (' function value does not seem to depend on any of the', + i3,' variable parameters.' /10x,'verify that step sizes are', + ' big enough and check fcn logic.'/1x,79(1h*)/1x,79(1h*)/) end cdeck id>, mnread. subroutine mnread(fcn,iflgin,iflgut,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from minuit. reads all user input to minuit. cc this routine is highly unstructured and defies normal logic. cc cc iflgin indicates the function originally requested: cc = 1: read one-line title cc 2: read parameter definitions cc 3: read minuit commands cc cc iflgut= 1: reading terminated normally cc 2: end-of-data on input cc 3: unrecoverable read error cc 4: unable to process parameter requests cc internally, cc iflgdo indicates the subfunction to be performed on the next cc input record: 1: read a one-line title cc 2: read a parameter definition cc 3: read a command cc 4: read in covariance matrix cc for example, when iflgin=3, but iflgdo=1, then it should read cc a title, but this was requested by a command, not by minuit. cc 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 dimension plist(maxp) character cnamk*10, crdbuf*80, celmnt*20 character comand*(maxcwd) character cpromt(3)*40, clower*26, cupper*26 logical leof data cpromt/' enter minuit title, or "set input n" : ', + ' enter minuit parameter definition: ', + ' enter minuit command: '/ c data clower/'abcdefghijklmnopqrstuvwxyz'/ data cupper/'abcdefghijklmnopqrstuvwxyz'/ c iflgut = 1 iflgdo = iflgin ifatal = 0 leof = .false. c . . . . read next record 10 continue if (isw(6) .eq. 1) write (isyswr,'(a)') cpromt(iflgdo) crdbuf = ' ' read (isysrd,'(a)',err=500,end=45) crdbuf c . . preemptive commands leof = .false. if (index(crdbuf,'*eof') .eq. 1 .or. + index(crdbuf,'*eof') .eq. 1) then write (isyswr,'(a,i3)') ' *eof encountered on unit no.',isysrd lphead = .true. go to 50 endif if (index(crdbuf,'set inp') .eq. 1 .or. + index(crdbuf,'set inp') .eq. 1) then icomnd = icomnd + 1 write (isyswr, 21) icomnd,crdbuf(1:50) 21 format (' **********'/' **',i5,' **',a/' **********') lphead = .true. go to 50 endif go to 80 c . . hardware eof on current isysrd 45 crdbuf = '*eof ' write (isyswr,'(a,i3)') ' end of data on unit no.',isysrd c or set input command 50 continue call mnstin(crdbuf,ierr) if (ierr .eq. 0) go to 10 if (ierr .eq. 2) then if (.not. leof) then write (isyswr,'(a,a/)') ' two consecutive eofs on ', + 'primary input file will terminate execution.' leof = .true. go to 10 endif endif iflgut = ierr go to 900 80 if (iflgdo .gt. 1) go to 100 c read title . . . . . iflgdo = 1 c if title is 'set title', skip and read again if (index(crdbuf,'set tit') .eq. 1) go to 10 if (index(crdbuf,'set tit') .eq. 1) go to 10 ctitl = crdbuf(1:50) write (isyswr,'(1x,a50)') ctitl write (isyswr,'(1x,78(1h*))') lphead = .true. if (iflgin .eq. iflgdo) go to 900 iflgdo = iflgin go to 10 c data record is not a title. get upper case 100 continue do 110 i= 1, maxcwd if (crdbuf(i:i) .eq. '''') go to 111 do 108 ic= 1, 26 if (crdbuf(i:i) .eq. clower(ic:ic)) crdbuf(i:i)=cupper(ic:ic) 108 continue 110 continue 111 continue c read parameter definitions. iflgdo = 2 if (iflgdo .gt. 2) go to 300 c if parameter def is 'parameter', skip and read again if (index(crdbuf,'par') .eq. 1) go to 10 c if line starts with set title, read a title first if (index(crdbuf,'set tit') .eq. 1) then iflgdo = 1 go to 10 endif c find out whether fixed or free-field format kapo1 = index(crdbuf,'''') if (kapo1 .eq. 0) go to 150 kapo2 = index(crdbuf(kapo1+1:),'''') if (kapo2 .eq. 0) go to 150 c new (free-field) format kapo2 = kapo2 + kapo1 c skip leading blanks if any do 115 istart=1, kapo1-1 if (crdbuf(istart:istart) .ne. ' ') go to 120 115 continue istart = kapo1-1 120 continue c parameter number integer if (istart .lt. 1) go to 210 celmnt = crdbuf(istart:kapo1-1) read (celmnt,'(bn,f20.0)',err=180) fk k = fk if (k .eq. 0) go to 210 cnamk = 'param '//celmnt if (kapo2-kapo1 .gt. 1) cnamk = crdbuf(kapo1+1:kapo2-1) call mncrck(crdbuf(kapo2+1:),maxcwd,comand,lnc, + maxp,plist,llist, ierr,isyswr) if (ierr .gt. 0) go to 180 uk = plist(1) wk = 0. if (llist .ge. 2) wk = plist(2) a = 0. if (llist .ge. 3) a = plist(3) b = 0. if (llist .ge. 4) b = plist(4) go to 170 c old (fixed-field) format 150 continue read (crdbuf, 158,err=180) xk,cnamk,uk,wk,a,b 158 format (bn,f10.0, a10, 4f10.0) k = xk if (k .eq. 0) go to 210 c parameter format cracked, implement parameter definition 170 call mnparm(k,cnamk,uk,wk,a,b,ierr) if (ierr .eq. 0) go to 10 c format error 180 continue if (isw(6) .eq. 1) then write (isyswr,'(a)') ' format error. ignored. enter again.' else write (isyswr,'(a)') ' error in parameter definition' ifatal = ifatal + 1 endif go to 10 c . . . end parameter requests 210 write (isyswr,'(4x,75(1h*))') if (ifatal.gt.0 .and. isw(6).ne.1) then iflgut = 4 go to 900 endif if (iflgin .eq. iflgdo) go to 900 iflgdo = iflgin go to 10 c . . . . . iflgdo = 3 c read commands 300 continue c crack the next command . . . . . . . . . . . . . . . . do 350 ipos= 1, 80 if (crdbuf(ipos:ipos) .ne. ' ') go to 355 350 continue write (isyswr,'(a)') ' blank command ignored.' go to 10 355 ibegin = ipos call mncrck(crdbuf(ibegin:),maxcwd,comand,lnc, + maxp, plist, llist, ierr,isyswr) if (ierr .gt. 0) then if (isw(6) .eq. 1) then write (isyswr,'(a)') ' command ignored ' go to 10 else write (isyswr,'(a)') ' command cannot be interpreted' go to 500 endif endif c certain commands are trapped here already lphead = .true. if (index(comand,'par' ) .eq. 1) go to 440 if (index(comand,'set') .ne. 1) go to 370 if (index(comand,'cov') .eq. 5) go to 400 if (index(comand,'tit') .eq. 5) go to 460 370 continue call mnexcm(fcn,comand(1:lnc),plist,llist,ierr,futil) if (comand(1:3).eq.'end') go to 900 if (comand(1:3).eq.'exi') go to 900 if (comand(1:3).eq.'ret') go to 900 if (comand(1:3).eq.'sto') go to 900 go to 10 c . . . . . . . . . . set covar 400 nrape = plist(1) icomnd = icomnd + 1 write (isyswr,405) icomnd,comand(1:lnc),(plist(i),i=1,llist) 405 format (1h ,10(1h*)/' **',i5,' **',a,4g12.4/20x,5g12.4) write (isyswr, '(1h ,10(1h*))' ) if (nrape .ne. npar) go to 425 npar2 = npar*(npar+1)/2 read (isysrd,420,err=500,end=45) (vhmat(i),i=1,npar2) 420 format (bn,7e11.4,3x) isw(2) = 3 dcovar = 0.0 if (isw(5) .ge. 0) call mnmatu(1) if (isw(5) .ge. 1) call mnprin(2,amin) go to 10 425 continue write (isyswr,428) 428 format(' size of covariance matrix to be read does not', + ' correspond to'/' number of currently variable parameters.', + ' command ignored.'/) read (isysrd,420,err=500,end=45) ((dummy,i=1,j),j=1,nrape) go to 10 c . . . . . parameter command 440 continue iflgdo = 2 ifatal = 0 c go and read parameter definitions go to 10 c . . . . set title 460 continue iflgdo = 1 go to 10 c . . . . error conditions 500 iflgut = 3 900 return end cdeck id>, mnrn15. subroutine mnrn15(val,inseed) c ************ double precision version ************* implicit double precision (a-h,o-z) c this is a super-portable random number generator. c it should not overflow on any 32-bit machine. c the cycle is only ~10**9, so use with care! c note especially that val must not be undefined on input. c set default starting seed parameter (three=3.0) data iseed/12345/ if (val .eq. three) go to 100 c inseed = iseed k = iseed/53668 iseed = 40014*(iseed-k*53668) - k*12211 if (iseed .lt. 0) iseed = iseed + 2147483563 val = real(iseed) * 4.656613e-10 return c "entry" to set seed, flag is val=3. 100 iseed = inseed return end cdeck id>, mnrset. subroutine mnrset(iopt) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mncler and whenever problem changes, for example cc after set limits, set param, call fcn 6 cc if iopt=1, cc resets function value and errors to undefined cc if iopt=0, sets only minos errors to undefined 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 cstatu = 'reset ' if (iopt .ge. 1) then amin = undefi fval3 = 2.0*abs(amin) + 1. edm = bigedm isw(4) = 0 isw(2) = 0 dcovar = 1. isw(1) = 0 endif lnolim = .true. do 10 i= 1, npar iext = nexofi(i) if (nvarl(iext) .ge. 4) lnolim=.false. erp(i) = zero ern(i) = zero globcc(i) = zero 10 continue if (isw(2) .ge. 1) then isw(2) = 1 dcovar = max(dcovar,half) endif return end cdeck id>, mnsave. subroutine mnsave c ************ double precision version ************* implicit double precision (a-h,o-z) cc writes current parameter values and step sizes onto file isyssa cc in format which can be reread by minuit for restarting. cc the covariance matrix is also output if it exists. cc 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 dimension vc(7) logical lopen,lname character cgname*64, cfname*64, canswr*1 c inquire(unit=isyssa,opened=lopen,named=lname,name=cgname) if (lopen) then if (.not.lname) cgname='unnamed file' write (isyswr,32) isyssa,cgname 32 format (' current values will be saved on unit',i3,': ',a/) else c new file, open it write (isyswr,35) isyssa 35 format (' unit',i3,' is not opened.') if (isw(6) .eq. 1) then write (isyswr,'(a)') ' please give file name:' read (isysrd,'(a)') cfname open (unit=isyssa,file=cfname,status='new',err=600) cgname = cfname else go to 650 endif endif c file is now correctly opened if (isw(6) .eq. 1) then write (isyswr,37) isyssa 37 format (' should unit',i3,' be rewound before writing to it?' ) read (isysrd,'(a)') canswr if (canswr.eq.'y' .or. canswr.eq.'y') rewind isyssa endif c and rewound if requested write (isyssa,'(10hset title )',err=700) write (isyssa,'(a)') ctitl write (isyssa,'(10hparameters)') nlines = 3 c write out parameter values do 200 i= 1, nu if (nvarl(i) .lt. 0) go to 200 nlines = nlines + 1 iint = niofex(i) if (nvarl(i) .gt. 1) go to 100 c parameter without limits write (isyssa,1001) i,cpnam(i),u(i),werr(iint) go to 200 c parameter with limits 100 continue write (isyssa,1001) i,cpnam(i),u(i),werr(iint),alim(i),blim(i) 1001 format (1x,i5,1h',a10,1h',4e13.5) 200 continue write (isyssa,'(a)') ' ' nlines = nlines + 1 c write out covariance matrix, if any if (isw(2) .lt. 1) go to 750 write (isyssa,1003,err=700) npar 1003 format ('set covariance',i6) npar2 = npar*(npar+1)/2 write (isyssa,1004) (vhmat(i),i=1,npar2) 1004 format (bn,7e11.4,3x) ncovar = npar2/7 + 1 if (mod(npar2,7) .gt. 0) ncovar = ncovar + 1 nlines = nlines + ncovar write (isyswr, 501) nlines,isyssa,cgname(1:45) 501 format (1x,i5,' records written to unit',i4,':',a) if (ncovar .gt. 0) write (isyswr, 502) ncovar 502 format (' including',i5,' records for the covariance matrix.'/) go to 900 c some error conditions 600 write (isyswr,'(a,i4)') ' i/o error: unable to open unit',isyssa go to 900 650 write (isyswr,'(a,i4,a)') ' unit',isyssa,' is not opened.' go to 900 700 write (isyswr,'(a,i4)') ' error: unable to write to unit',isyssa go to 900 750 write (isyswr,'(a)') ' there is no covariance matrix to save.' c 900 return end cdeck id>, mnscan. subroutine mnscan(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc scans the values of fcn as a function of one parameter cc and plots the resulting values as a curve using mnplot. cc it may be called to scan one parameter or all parameters. cc retains the best function and parameter values found. 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 xlreq = min(word7(3),word7(4)) xhreq = max(word7(3),word7(4)) ncall = word7(2) + 0.01 if (ncall .le. 1) ncall = 41 if (ncall .gt. maxcpt) ncall = maxcpt nccall = ncall if (amin .eq. undefi) call mnamin(fcn,futil) iparwd = word7(1) + 0.1 ipar = max(iparwd, 0) iint = niofex(ipar) cstatu = 'no change' if (iparwd .gt. 0) go to 200 c c equivalent to a loop over parameters requested 100 ipar = ipar + 1 if (ipar .gt. nu) go to 900 iint = niofex(ipar) if (iint .le. 0) go to 100 c set up range for parameter ipar 200 continue ubest = u(ipar) xpt(1) = ubest ypt(1) = amin chpt(1)= ' ' xpt(2) = ubest ypt(2) = amin chpt(2)= 'x' nxypt = 2 if (nvarl(ipar) .gt. 1) go to 300 c no limits on parameter if (xlreq .eq. xhreq) go to 250 unext = xlreq step = (xhreq-xlreq)/float(ncall-1) go to 500 250 continue xl = ubest - werr(iint) xh = ubest+ werr(iint) call mnbins(xl,xh,ncall, unext,uhigh,nbins,step) nccall = nbins + 1 go to 500 c limits on parameter 300 continue if (xlreq .eq. xhreq) go to 350 xl = max(xlreq,alim(ipar)) xh = min(xhreq,blim(ipar)) if (xl .ge. xh) go to 700 unext = xl step = (xh-xl)/float(ncall-1) go to 500 350 continue unext = alim(ipar) step = (blim(ipar)-alim(ipar))/float(ncall-1) c main scanning loop over parameter ipar 500 continue do 600 icall = 1, nccall u(ipar) = unext nparx = npar call fcn(nparx,gin,fnext,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 xpt(nxypt) = unext ypt(nxypt) = fnext chpt(nxypt) = '*' if (fnext .lt. amin) then amin = fnext ubest = unext cstatu= 'improved ' endif 530 continue unext = unext + step 600 continue c finished with scan of parameter ipar u(ipar) = ubest call mnexin(x) write (isyswr,1001) newpag,ipar,cpnam(ipar) nunit = isyswr call mnplot(xpt,ypt,chpt,nxypt,nunit,npagwd,npagln) go to 800 700 continue write (isyswr,1000) ipar 800 continue if (iparwd .le. 0) go to 100 c finished with all parameters 900 continue call mnprin(5,amin) return 1000 format (46h requested range outside limits for parameter ,i3/) 1001 format (i1,'scan of parameter no.',i3,3h, ,a10) end cdeck id>, mnseek. subroutine mnseek(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a rough (but global) minimization by monte carlo search. cc each time a new minimum is found, the search area is shifted cc to be centered at the best value. random points are chosen cc uniformly over a hypercube determined by current step sizes. cc the metropolis algorithm accepts a worse point with probability cc exp(-d/up), where d is the degradation. improved points cc are of course always accepted. actual steps are random cc multiples of the nominal steps (dirin). cc 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 parameter (twopi=2.0*3.141593) dimension step(mni), xbest(mni), xmid(mni) mxfail = word7(1) if (mxfail .le. 0) mxfail=100+20*npar mxstep = 10*mxfail if (amin .eq. undefi) call mnamin(fcn,futil) alpha = word7(2) if (alpha .le. zero) alpha=3. if (isw(5) .ge. 1) write (isyswr, 3) mxfail,mxstep,alpha 3 format (' mnseek: monte carlo minimization using metropolis', + ' algorithm'/' to stop after',i6,' successive failures, or', + i7,' steps'/' maximum step size is',f9.3,' error bars.') cstatu= 'initial ' if (isw(5) .ge. 2) call mnprin(2,amin) cstatu = 'unchanged ' ifail = 0 rnum = zero rnum1 = zero rnum2 = zero nparx = npar flast = amin c set up step sizes, starting values do 10 ipar = 1, npar iext = nexofi(ipar) dirin(ipar) = 2.0*alpha*werr(ipar) if (nvarl(iext) .gt. 1) then c parameter with limits call mndxdi(x(ipar),ipar,dxdi) if (dxdi .eq. zero) dxdi=1. dirin(ipar) = 2.0*alpha*werr(ipar)/dxdi if (abs(dirin(ipar)).gt.twopi) dirin(ipar)=twopi endif xmid(ipar) = x(ipar) 10 xbest(ipar) = x(ipar) c search loop do 500 istep= 1, mxstep if (ifail .ge. mxfail) go to 600 do 100 ipar= 1, npar call mnrn15(rnum1,iseed) call mnrn15(rnum2,iseed) 100 x(ipar) = xmid(ipar) + 0.5*(rnum1+rnum2-1.)*dirin(ipar) call mninex(x) call fcn(nparx,gin,ftry,u,4,futil) nfcn = nfcn + 1 if (ftry .lt. flast) then if (ftry .lt. amin) then cstatu = 'improvemnt' amin = ftry do 200 ib= 1, npar 200 xbest(ib) = x(ib) ifail = 0 if (isw(5) .ge. 2) call mnprin(2,amin) endif go to 300 else ifail = ifail + 1 c metropolis algorithm bar = exp((amin-ftry)/up) call mnrn15(rnum,iseed) if (bar .lt. rnum) go to 500 endif c accept new point, move there 300 continue do 350 j= 1, npar xmid(j) = x(j) 350 continue flast = ftry 500 continue c end search loop 600 continue if (isw(5) .gt. 1) write (isyswr,601) ifail 601 format(' mnseek:',i5,' successive unsuccessful trials.') do 700 ib= 1, npar 700 x(ib) = xbest(ib) call mninex(x) if (isw(5) .ge. 1) call mnprin(2,amin) if (isw(5) .eq. 0) call mnprin(0,amin) return end cdeck id>, mnset. subroutine mnset(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnexcm cc interprets the commands that start with set and show cc 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 c external fcn,futil c file characteristics for set input logical lopen,lname character*1 canswr character cfname*64, cmode*16 c 'set ' or 'show', 'on ' or 'off', 'suppressed' or 'reported ' character ckind*4, copt*3, cwarn*10 c explanation of print level numbers -1:3 and strategies 0:2 character cprlev(-1:3)*34 ,cstrat(0:2)*44 c identification of debug options parameter (numdbg = 6) character*40 cdbopt(0:numdbg) c things that can be set or shown character*10 cname(30) data cname( 1)/'fcn value '/ data cname( 2)/'parameters'/ data cname( 3)/'limits '/ data cname( 4)/'covariance'/ data cname( 5)/'correlatio'/ data cname( 6)/'print levl'/ data cname( 7)/'nogradient'/ data cname( 8)/'gradient '/ data cname( 9)/'error def '/ data cname(10)/'input file'/ data cname(11)/'width page'/ data cname(12)/'lines page'/ data cname(13)/'nowarnings'/ data cname(14)/'warnings '/ data cname(15)/'random gen'/ data cname(16)/'title '/ data cname(17)/'strategy '/ data cname(18)/'eigenvalue'/ data cname(19)/'page throw'/ data cname(20)/'minos errs'/ data cname(21)/'epsmachine'/ data cname(22)/'outputfile'/ data cname(23)/'batch '/ data cname(24)/'interactiv'/ data nname/24/ c options not intended for normal users data cname(25)/'reserve '/ data cname(26)/'reserve '/ data cname(27)/'nodebug '/ data cname(28)/'debug '/ data cname(29)/'show '/ data cname(30)/'set '/ data nntot/30/ c data cprlev(-1)/'-1: no output except from "show" '/ data cprlev( 0)/' 0: reduced output '/ data cprlev( 1)/' 1: normal output '/ data cprlev( 2)/' 2: extra output for problem cases'/ data cprlev( 3)/' 3: maximum output '/ c data cstrat( 0)/' 0: minimize the number of calls to function'/ data cstrat( 1)/' 1: try to balance speed against reliability'/ data cstrat( 2)/' 2: make sure minimum true, errors correct '/ c data cdbopt(0)/'report all exceptional conditions '/ data cdbopt(1)/'mnline: line search minimization '/ data cdbopt(2)/'mnderi: first derivative calculations '/ data cdbopt(3)/'mnhess: second derivative calculations '/ data cdbopt(4)/'mnmigr: covariance matrix updates '/ data cdbopt(5)/'mnhes1: first derivative uncertainties '/ data cdbopt(6)/'mncont: mncontour plot (mncros search) '/ c c do 2 i= 1, nntot if (index(cword(4:10),cname(i)(1:3)) .gt. 0) go to 5 2 continue i = 0 5 kname = i c c command could be set xxx, show xxx, help set or help show if (index(cword(1:4),'hel') .gt. 0) go to 2000 if (index(cword(1:4),'sho') .gt. 0) go to 1000 if (index(cword(1:4),'set') .eq. 0) go to 1900 c --- ckind = 'set ' c . . . . . . . . . . set unknown if (kname .le. 0) go to 1900 c . . . . . . . . . . set known go to(3000, 20, 30, 40,3000, 60, 70, 80, 90, 100, + 110, 120, 130, 140, 150, 160, 170,3000, 190,3000, + 210, 220, 230, 240,1900,1900, 270, 280, 290, 300) , kname c c . . . . . . . . . . set param 20 continue iprm = word7(1) if (iprm .gt. nu) go to 25 if (iprm .le. 0) go to 25 if (nvarl(iprm) .lt. 0) go to 25 u(iprm) = word7(2) call mnexin(x) isw2 = isw(2) call mnrset(1) c keep approximate covariance matrix, even if new param value isw(2) = min(isw2,1) cfrom = 'set parm' nfcnfr = nfcn cstatu = 'new values' go to 4000 25 write (isyswr,'(a/)') ' undefined parameter number. ignored.' go to 4000 c . . . . . . . . . . set limits 30 call mnlims(fcn,futil) go to 4000 c . . . . . . . . . . set covar 40 continue c this command must be handled by mnread, and is not fortran-callable go to 3000 c . . . . . . . . . . set print 60 isw(5) = word7(1) go to 4000 c . . . . . . . . . . set nograd 70 isw(3) = 0 go to 4000 c . . . . . . . . . . set grad 80 call mngrad(fcn,futil) go to 4000 c . . . . . . . . . . set errdef 90 if (word7(1) .eq. up) go to 4000 if (word7(1) .le. zero) then if (up .eq. updflt) go to 4000 up = updflt else up = word7(1) endif do 95 i= 1, npar ern(i) = 0. 95 erp(i) = 0. call mnwerr go to 4000 c . . . . . . . . . . set input c this command must be handled by mnread. if it gets this far, c it is illegal. 100 continue go to 3000 c . . . . . . . . . . set width 110 npagwd = word7(1) npagwd = max(npagwd,50) go to 4000 c . . . . . . . . . . set lines 120 npagln = word7(1) go to 4000 c . . . . . . . . . . set nowarn 130 lwarn = .false. go to 4000 c . . . . . . . . . . set warn 140 lwarn = .true. call mnwarn('w','sho','sho') go to 4000 c . . . . . . . . . . set random 150 jseed = int(word7(1)) val = 3. call mnrn15(val, jseed) if (isw(5) .gt. 0) write (isyswr, 151) jseed 151 format (' minuit random number seed set to ',i10) go to 4000 c . . . . . . . . . . set title 160 continue c this command must be handled by mnread, and is not fortran-callable go to 3000 c . . . . . . . . . set strategy 170 istrat = word7(1) istrat = max(istrat,0) istrat = min(istrat,2) if (isw(5) .gt. 0) go to 1172 go to 4000 c . . . . . . . . . set page throw 190 newpag = word7(1) go to 1190 c . . . . . . . . . . set epsmac 210 if (word7(1).gt.zero .and. word7(1).lt.0.1) epsmac = word7(1) epsma2 = dsqrt(epsmac) go to 1210 c . . . . . . . . . . set outputfile 220 continue iunit = word7(1) isyswr = iunit istkwr(1) = iunit if (isw(5) .ge. 0) go to 1220 go to 4000 c . . . . . . . . . . set batch 230 isw(6) = 0 if (isw(5) .ge. 0) go to 1100 go to 4000 c . . . . . . . . . . set interactive 240 isw(6) = 1 if (isw(5) .ge. 0) go to 1100 go to 4000 c . . . . . . . . . . set nodebug 270 iset = 0 go to 281 c . . . . . . . . . . set debug 280 iset = 1 281 continue idbopt = word7(1) if (idbopt .gt. numdbg) go to 288 if (idbopt .ge. 0) then idbg(idbopt) = iset if (iset .eq. 1) idbg(0) = 1 else c set debug -1 sets all debug options do 285 id= 0, numdbg 285 idbg(id) = iset endif lrepor = (idbg(0) .ge. 1) call mnwarn('d','sho','sho') go to 4000 288 write (isyswr,289) idbopt 289 format (' unknown debug option',i6,' requested. ignored') go to 4000 c . . . . . . . . . . set show 290 continue c . . . . . . . . . . set set 300 continue go to 3000 c ----------------------------------------------------- 1000 continue c at this point, cword must be 'show' ckind = 'show' if (kname .le. 0) go to 1900 go to (1010,1020,1030,1040,1050,1060,1070,1070,1090,1100, + 1110,1120,1130,1130,1150,1160,1170,1180,1190,1200, + 1210,1220,1100,1100,1900,1900,1270,1270,1290,1300),kname c c . . . . . . . . . . show fcn 1010 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (0,amin) go to 4000 c . . . . . . . . . . show param 1020 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (5,amin) go to 4000 c . . . . . . . . . . show limits 1030 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (1,amin) go to 4000 c . . . . . . . . . . show covar 1040 call mnmatu(1) go to 4000 c . . . . . . . . . . show corre 1050 call mnmatu(0) go to 4000 c . . . . . . . . . . show print 1060 continue if (isw(5) .lt.-1) isw(5) = -1 if (isw(5) .gt. 3) isw(5) = 3 write (isyswr,'(a)') ' allowed print levels are:' write (isyswr,'(27x,a)') cprlev write (isyswr,1061) cprlev(isw(5)) 1061 format (/' current printout level is ',a) go to 4000 c . . . . . . . show nograd, grad 1070 continue if (isw(3) .le. 0) then write (isyswr, 1081) 1081 format(' nograd is set. derivatives not computed in fcn.') else write (isyswr, 1082) 1082 format(' grad is set. user computes derivatives in fcn.') endif go to 4000 c . . . . . . . . . . show errdef 1090 write (isyswr, 1091) up 1091 format (' errors correspond to function change of',g13.5) go to 4000 c . . . . . . . . . . show input, c batch, or interactive 1100 continue inquire(unit=isysrd,opened=lopen,named=lname,name=cfname) cmode = 'batch mode ' if (isw(6) .eq. 1) cmode = 'interactive mode' if (.not. lname) cfname='unknown' write (isyswr,1002) cmode,isysrd,cfname 1002 format (' input now being read in ',a,' from unit no.',i3/ + ' filename: ',a) go to 4000 c . . . . . . . . . . show width 1110 write (isyswr,1111) npagwd 1111 format (10x,'page width is set to',i4,' columns') go to 4000 c . . . . . . . . . . show lines 1120 write (isyswr,1121) npagln 1121 format (10x,'page length is set to',i4,' lines') go to 4000 c . . . . . . .show nowarn, warn 1130 continue cwarn = 'suppressed' if (lwarn) cwarn = 'reported ' write (isyswr,1141) cwarn 1141 format (' minuit warning messages are ',a) if (.not. lwarn) call mnwarn('w','sho','sho') go to 4000 c . . . . . . . . . . show random 1150 val = 0. call mnrn15(val,igrain) ikseed = igrain write (isyswr, 1151) ikseed 1151 format (' minuit rndm seed is currently=',i10/) val = 3.0 iseed = ikseed call mnrn15(val,iseed) go to 4000 c . . . . . . . . . show title 1160 write (isyswr,'(a,a)') ' title of current task is:',ctitl go to 4000 c . . . . . . . show strategy 1170 write (isyswr, '(a)') ' allowed strategies are:' write (isyswr, '(20x,a)') cstrat 1172 write (isyswr, 1175) cstrat(istrat) 1175 format (/' now using strategy ',a/) go to 4000 c . . . . . show eigenvalues 1180 continue iswsav = isw(5) isw(5) = 3 if (isw(2) .lt. 1) then write (isyswr,'(1x,a)') covmes(0) else call mnpsdf endif isw(5) = iswsav go to 4000 c . . . . . show page throw 1190 write (isyswr,'(a,i3)') ' page throw carriage control =',newpag if (newpag .eq. 0) + write (isyswr,'(a)') ' no page throws in minuit output' go to 4000 c . . . . . . show minos errors 1200 continue do 1202 ii= 1, npar if (erp(ii).gt.zero .or. ern(ii).lt.zero) go to 1204 1202 continue write (isyswr,'(a)') + ' there are no minos errors currently valid.' go to 4000 1204 continue call mnprin(4,amin) go to 4000 c . . . . . . . . . show epsmac 1210 write (isyswr,'(a,e12.3)') + ' floating-point numbers assumed accurate to',epsmac go to 4000 c . . . . . . show outputfiles 1220 continue write (isyswr,'(a,i4)') ' minuit primary output to unit',isyswr go to 4000 c . . . . . . show nodebug, debug 1270 continue do 1285 id= 0, numdbg copt = 'off' if (idbg(id) .ge. 1) copt = 'on ' 1285 write (isyswr,1286) id, copt, cdbopt(id) 1286 format (10x,'debug option',i3,' is ',a3,' :',a) if (.not. lrepor) call mnwarn('d','sho','sho') go to 4000 c . . . . . . . . . . show show 1290 ckind = 'show' go to 2100 c . . . . . . . . . . show set 1300 ckind = 'set ' go to 2100 c ----------------------------------------------------- c unknown command 1900 write (isyswr, 1901) cword 1901 format (' the command:',a10,' is unknown.'/) go to 2100 c ----------------------------------------------------- c help show, help set, show set, or show show 2000 ckind = 'set ' if (index(cword(4:10),'sho') .gt. 0) ckind = 'show' 2100 write (isyswr, 2101) ckind,ckind, (cname(kk),kk=1,nname) 2101 format (' the format of the ',a4,' command is:'// + 1x,a4,' xxx [numerical arguments if any]'// + ' where xxx may be one of the following:'/ + (7x,6a12)) go to 4000 c ----------------------------------------------------- c illegal command 3000 write (isyswr,'('' above command is illegal. ignored'')') 4000 return end cdeck id>, mnseti. subroutine mnseti(tit) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user to set or change title of current task. cc 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 character*(*) tit ctitl = tit return end cdeck id>, mnsimp. subroutine mnsimp(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minimization using the simplex method of nelder cc and mead (ref. -- comp. j. 7,308 (1965)). cc 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 dimension y(mni+1) data alpha,beta,gamma,rhomin,rhomax / 1.0, 0.5, 2.0, 4.0, 8.0/ if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) cfrom = 'simplex ' nfcnfr = nfcn cstatu= 'unchanged ' npfn=nfcn nparp1=npar+1 nparx = npar rho1 = 1.0 + alpha rho2 = rho1 + alpha*gamma wg = 1.0/float(npar) if (isw(5) .ge. 0) write(isyswr,100) epsi 100 format(' start simplex minimization. convergence when edm .lt.' +,e10.2 ) do 2 i= 1, npar dirin(i) = werr(i) call mndxdi(x(i),i,dxdi) if (dxdi .ne. zero) dirin(i)=werr(i)/dxdi dmin = epsma2*abs(x(i)) if (dirin(i) .lt. dmin) dirin(i)=dmin 2 continue c** choose the initial simplex using single-parameter searches 1 continue ynpp1 = amin jl = nparp1 y(nparp1) = amin absmin = amin do 10 i= 1, npar aming = amin pbar(i) = x(i) bestx = x(i) kg = 0 ns = 0 nf = 0 4 x(i) = bestx + dirin(i) call mninex(x) call fcn(nparx,gin, f, u, 4, futil) nfcn = nfcn + 1 if (f .le. aming) go to 6 c failure if (kg .eq. 1) go to 8 kg = -1 nf = nf + 1 dirin(i) = dirin(i) * (-0.4) if (nf .lt. 3) go to 4 ns = 6 c success 6 bestx = x(i) dirin(i) = dirin(i) * 3.0 aming = f cstatu= 'progress ' kg = 1 ns = ns + 1 if (ns .lt. 6) go to 4 c local minimum found in ith direction 8 y(i) = aming if (aming .lt. absmin) jl = i if (aming .lt. absmin) absmin = aming x(i) = bestx do 9 k= 1, npar 9 p(k,i) = x(k) 10 continue jh = nparp1 amin=y(jl) call mnrazz(ynpp1,pbar,y,jh,jl) do 20 i= 1, npar 20 x(i) = p(i,jl) call mninex(x) cstatu = 'progress ' if (isw(5) .ge. 1) call mnprin(5,amin) edm = bigedm sig2 = edm ncycl=0 c . . . . . start main loop 50 continue if (sig2 .lt. epsi .and. edm.lt.epsi) go to 76 sig2 = edm if ((nfcn-npfn) .gt. nfcnmx) go to 78 c calculate new point * by reflection do 60 i= 1, npar pb = 0. do 59 j= 1, nparp1 59 pb = pb + wg * p(i,j) pbar(i) = pb - wg * p(i,jh) 60 pstar(i)=(1.+alpha)*pbar(i)-alpha*p(i,jh) call mninex(pstar) call fcn(nparx,gin,ystar,u,4,futil) nfcn=nfcn+1 if(ystar.ge.amin) go to 70 c point * better than jl, calculate new point ** do 61 i=1,npar 61 pstst(i)=gamma*pstar(i)+(1.-gamma)*pbar(i) call mninex(pstst) call fcn(nparx,gin,ystst,u,4,futil) nfcn=nfcn+1 c try a parabola through ph, pstar, pstst. min = prho y1 = (ystar-y(jh)) * rho2 y2 = (ystst-y(jh)) * rho1 rho = 0.5 * (rho2*y1 -rho1*y2) / (y1 -y2) if (rho .lt. rhomin) go to 66 if (rho .gt. rhomax) rho = rhomax do 64 i= 1, npar 64 prho(i) = rho*pbar(i) + (1.0-rho)*p(i,jh) call mninex(prho) call fcn(nparx,gin,yrho, u,4,futil) nfcn = nfcn + 1 if (yrho .lt. y(jl) .and. yrho .lt. ystst) go to 65 if (ystst .lt. y(jl)) go to 67 if (yrho .gt. y(jl)) go to 66 c accept minimum point of parabola, prho 65 call mnrazz (yrho,prho,y,jh,jl) go to 68 66 if (ystst .lt. y(jl)) go to 67 call mnrazz(ystar,pstar,y,jh,jl) go to 68 67 call mnrazz(ystst,pstst,y,jh,jl) 68 ncycl=ncycl+1 if (isw(5) .lt. 2) go to 50 if (isw(5) .ge. 3 .or. mod(ncycl, 10) .eq. 0) call mnprin(5,amin) go to 50 c point * is not as good as jl 70 if (ystar .ge. y(jh)) go to 73 jhold = jh call mnrazz(ystar,pstar,y,jh,jl) if (jhold .ne. jh) go to 50 c calculate new point ** 73 do 74 i=1,npar 74 pstst(i)=beta*p(i,jh)+(1.-beta)*pbar(i) call mninex (pstst) call fcn(nparx,gin,ystst,u,4,futil) nfcn=nfcn+1 if(ystst.gt.y(jh)) go to 1 c point ** is better than jh if (ystst .lt. amin) go to 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c . . . . . . end main loop 76 if (isw(5) .ge. 0) write(isyswr,'(a)') + ' simplex minimization has converged.' isw(4) = 1 go to 80 78 if (isw(5) .ge. 0) write(isyswr,'(a)') + ' simplex terminates without convergence.' cstatu= 'call limit' isw(4) = -1 isw(1) = 1 80 do 82 i=1,npar pb = 0. do 81 j=1,nparp1 81 pb = pb + wg * p(i,j) 82 pbar(i) = pb - wg * p(i,jh) call mninex(pbar) call fcn(nparx,gin,ypbar,u,4,futil) nfcn=nfcn+1 if (ypbar .lt. amin) call mnrazz(ypbar,pbar,y,jh,jl) call mninex(x) if (nfcnmx+npfn-nfcn .lt. 3*npar) go to 90 if (edm .gt. 2.0*epsi) go to 1 90 if (isw(5) .ge. 0) call mnprin(5, amin) return end cdeck id>, mnstat. subroutine mnstat(fmin,fedm,errdef,npari,nparx,istat) c ************ double precision version ************* implicit double precision (a-h,o-z) cc user-called cc provides the user with information concerning the current status cc of the current minimization. namely, it returns: cc fmin: the best function value found so far cc fedm: the estimated vertical distance remaining to minimum cc errdef: the value of up defining parameter uncertainties cc npari: the number of currently variable parameters cc nparx: the highest (external) parameter number defined by user cc istat: a status integer indicating how good is the covariance cc matrix: 0= not calculated at all cc 1= approximation only, not accurate cc 2= full matrix, but forced positive-definite cc 3= full accurate covariance matrix cc 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 fmin = amin fedm = edm errdef = up npari = npar nparx = nu istat = isw(2) if (edm .eq. bigedm) then fedm = up endif if (amin .eq. undefi) then fmin = 0.0 fedm = up istat= 0 endif return end cdeck id>, mnstin. subroutine mnstin(crdbuf,ierr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnread. cc implements the set input command to change input units. cc if command is: 'set input' 'set input 0' or '*eof', cc or 'set input , , ', cc reverts to previous input unit number,if any. cc cc if it is: 'set input n' or 'set input n filename', cc changes to new input file, added to stack cc cc ierr = 0: reading terminated normally cc 2: end-of-data on primary input file cc 3: unrecoverable read error cc 4: unable to process request cc 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 character crdbuf*(*),cunit*10,cfname*64,cgname*64,canswr*1 character cmode*16 logical lopen,lrewin,noname,lname,mnunpt noname = .true. ierr = 0 if (index(crdbuf,'*eof') .eq. 1) go to 190 if (index(crdbuf,'*eof') .eq. 1) go to 190 lend = len(crdbuf) c look for end of set input command do 20 ic= 8,lend if (crdbuf(ic:ic) .eq. ' ') go to 25 if (crdbuf(ic:ic) .eq. ',') go to 53 20 continue go to 200 25 continue c look for end of separator between command and first argument icol = ic+1 do 50 ic= icol,lend if (crdbuf(ic:ic) .eq. ' ') go to 50 if (crdbuf(ic:ic) .eq. ',') go to 53 go to 55 50 continue go to 200 53 ic = ic + 1 55 ic1 = ic c see if "rewind" was requested in command lrewin = .false. if (index(crdbuf(1:ic1),'rew') .gt. 5) lrewin=.true. if (index(crdbuf(1:ic1),'rew') .gt. 5) lrewin=.true. c first argument begins in or after col ic1 do 75 ic= ic1,lend if (crdbuf(ic:ic) .eq. ' ') go to 75 if (crdbuf(ic:ic) .eq. ',') go to 200 go to 80 75 continue go to 200 80 ic1 = ic c first argument really begins in col ic1 do 100 ic= ic1+1,lend if (crdbuf(ic:ic) .eq. ' ') go to 108 if (crdbuf(ic:ic) .eq. ',') go to 108 100 continue ic = lend + 1 108 ic2 = ic-1 c end of first argument is in col ic2 110 continue cunit = crdbuf(ic1:ic2) write (isyswr,'(a,a)') ' unit no. :',cunit read (cunit,'(bn,f10.0)',err=500) funit iunit = funit if (iunit .eq. 0) go to 200 c skip blanks and commas, find file name do 120 ic= ic2+1,lend if (crdbuf(ic:ic) .eq. ' ') go to 120 if (crdbuf(ic:ic) .eq. ',') go to 120 go to 130 120 continue go to 131 130 continue cfname = crdbuf(ic:lend) noname = .false. write (isyswr, '(a,a)') ' file name is:',cfname c ask if file exists, if not ask for name and open it 131 continue inquire(unit=iunit,opened=lopen,named=lname,name=cgname) if (lopen) then if (noname) then go to 136 else if (.not.lname) cgname='unknown' write (isyswr,132) iunit,cgname,cfname 132 format (' unit',i3,' already opened with name:',a/ + ' new name ignored:',a) endif else c new file, open it write (isyswr,135) iunit 135 format (' unit',i3,' is not opened.') if (noname) then write (isyswr,'(a)') ' no file name given in command.' if (isw(6) .ne. 1) go to 800 write (isyswr,'(a)') ' please give file name:' read (isysrd,'(a)') cfname endif open (unit=iunit,file=cfname,status='old',err=600) write (isyswr,'(a)') ' file opened successfully.' endif c . . file is correctly opened 136 if (lrewin) go to 150 if (isw(6) .ne. 1) go to 300 write (isyswr,137) iunit 137 format (' should unit',i3,' be rewound?' ) read (isysrd,'(a)') canswr if (canswr.ne.'y' .and. canswr.ne.'y') go to 300 150 rewind iunit go to 300 c *eof 190 continue if (nstkrd .eq. 0) then ierr = 2 go to 900 endif c revert to previous input file 200 continue if (nstkrd .eq. 0) then write (isyswr, '(a,a)') ' command ignored:',crdbuf write (isyswr, '(a)') ' already reading from primary input' else isysrd = istkrd(nstkrd) nstkrd = nstkrd - 1 if (nstkrd .eq. 0) isw(6) = iabs(isw(6)) if (isw(5) .ge. 0) then inquire(unit=isysrd,named=lname,name=cfname) cmode = 'batch mode ' if (isw(6) .eq. 1) cmode = 'interactive mode' if (.not.lname) cfname='unknown' if (mnunpt(cfname)) cfname='unprintable' write (isyswr,290) cmode,isysrd,cfname 290 format (' input will now be read in ',a,' from unit no.',i3/ + ' filename: ',a) endif endif go to 900 c switch to new input file, add to stack 300 continue if (nstkrd .ge. maxstk) then write (isyswr, '(a)') ' input file stack size exceeded.' go to 800 endif nstkrd = nstkrd + 1 istkrd(nstkrd) = isysrd isysrd = iunit c isw(6) = 0 for batch, =1 for interactive, and c =-1 for originally interactive temporarily batch if (isw(6) .eq. 1) isw(6) = -1 go to 900 c format error 500 continue write (isyswr,'(a,a)') ' cannot read following as integer:',cunit go to 800 600 continue write (isyswr, 601) cfname 601 format (' system is unable to open file:',a) c serious error 800 continue ierr = 3 900 continue return end cdeck id>, mntiny. subroutine mntiny(epsp1,epsbak) c ************ double precision version ************* implicit double precision (a-h,o-z) cc compares its argument with the value 1.0, and returns cc the value .true. if they are equal. to find epsmac cc safely by foiling the fortran optimizer cc parameter (one=1.0) epsbak = epsp1 - one return end cdeck id>, mnunpt. logical function mnunpt(cfname) c is .true. if cfname contains unprintable characters. character cfname*(*) character cpt*80, cp1*40,cp2*40 parameter (cp1=' abcdefghijklmnopqrstuvwxyzabcdefghijklm') parameter (cp2='nopqrstuvwxyz1234567890./;:[]$%*_!@#&+()') cpt=cp1//cp2 mnunpt = .false. l = len(cfname) do 100 i= 1, l do 50 ic= 1, 80 if (cfname(i:i) .eq. cpt(ic:ic)) go to 100 50 continue mnunpt = .true. go to 150 100 continue 150 continue return end cdeck id>, mnvert. subroutine mnvert(a,l,m,n,ifail) c ************ double precision version ************* implicit double precision (a-h,o-z) cc inverts a symmetric matrix. matrix is first scaled to cc have all ones on the diagonal (equivalent to change of units) cc but no pivoting is done since matrix is positive-definite. cc 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 dimension a(l,m) ,pp(mni), q(mni), s(mni) ifail=0 if (n .lt. 1) go to 100 if (n .gt. maxint) go to 100 c scale matrix by dsqrt of diag elements do 8 i=1,n si = a(i,i) if (si) 100,100,8 8 s(i) = 1.0/dsqrt(si) do 20 i= 1, n do 20 j= 1, n 20 a(i,j) = a(i,j) *s(i)*s(j) c . . . start main loop . . . . do 65 i=1,n k = i c preparation for elimination step1 q(k)=1./a(k,k) pp(k) = 1.0 a(k,k)=0.0 kp1=k+1 km1=k-1 if(km1)100,50,40 40 do 49 j=1,km1 pp(j)=a(j,k) q(j)=a(j,k)*q(k) 49 a(j,k)=0. 50 if(k-n)51,60,100 51 do 59 j=kp1,n pp(j)=a(k,j) q(j)=-a(k,j)*q(k) 59 a(k,j)=0.0 c elimination proper 60 do 65 j=1,n do 65 k=j,n 65 a(j,k)=a(j,k)+pp(j)*q(k) c elements of left diagonal and unscaling do 70 j= 1, n do 70 k= 1, j a(k,j) = a(k,j) *s(k)*s(j) 70 a(j,k) = a(k,j) return c failure return 100 ifail=1 return end cdeck id>, mnwarn. subroutine mnwarn(copt,corg,cmes) c if copt='w', cmes is a warning message from corg. c if copt='d', cmes is a debug message from corg. c if set warnings is in effect (the default), this routine c prints the warning message cmes coming from corg. c if set nowarnings is in effect, the warning message is c stored in a circular buffer of length maxmes. c if called with corg=cmes='sho', it prints the messages in c the circular buffer, fifo, and empties the buffer. c ************ double precision version ************* implicit double precision (a-h,o-z) 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 character copt*1, corg*(*), cmes*(*), ctyp*7 parameter (maxmes=10) character origin(maxmes,2)*10, warmes(maxmes,2)*60 common/mn7wrc/origin, warmes common/mn7wri/nfcwar(maxmes,2),icirc(2) character englsh*20 c if (corg(1:3).eq.'sho' .and. cmes(1:3).eq.'sho') go to 200 c either print warning or put in buffer if (copt .eq. 'w') then ityp = 1 if (lwarn) then write (isyswr,'(a,a/a,a)') ' minuit warning in ',corg, + ' ============== ',cmes return endif else ityp = 2 if (lrepor) then write (isyswr,'(a,a/a,a)') ' minuit debug for ',corg, + ' ============== ',cmes return endif endif c if appropriate flag is off, fill circular buffer if (nwrmes(ityp) .eq. 0) icirc(ityp) = 0 nwrmes(ityp) = nwrmes(ityp) + 1 icirc(ityp) = icirc(ityp) + 1 if (icirc(ityp) .gt. maxmes) icirc(ityp) = 1 ic = icirc(ityp) origin(ic,ityp) = corg warmes(ic,ityp) = cmes nfcwar(ic,ityp) = nfcn return c c 'sho warnings', ask if any suppressed mess in buffer 200 continue if (copt .eq. 'w') then ityp = 1 ctyp = 'warning' else ityp = 2 ctyp = '*debug*' endif if (nwrmes(ityp) .gt. 0) then englsh = ' was suppressed. ' if (nwrmes(ityp) .gt. 1) englsh = 's were suppressed.' write (isyswr,'(/1x,i5,a,a,a,a/)') nwrmes(ityp), + ' minuit ',ctyp,' message', englsh nm = nwrmes(ityp) ic = 0 if (nm .gt. maxmes) then write (isyswr,'(a,i2,a)') ' only the most recent ', + maxmes,' will be listed below.' nm = maxmes ic = icirc(ityp) endif write (isyswr,'(a)') ' calls origin message' do 300 i= 1, nm ic = ic + 1 if (ic .gt. maxmes) ic = 1 write (isyswr,'(1x,i6,1x,a,1x,a)') + nfcwar(ic,ityp),origin(ic,ityp),warmes(ic,ityp) 300 continue nwrmes(ityp) = 0 write (isyswr,'(1h )') endif return end cdeck id>, mnwerr. subroutine mnwerr c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the werr, external parameter errors, cc and the global correlation coefficients, to be called cc whenever a new covariance matrix is available. cc 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 c calculate external error if v exists if (isw(2) .ge. 1) then do 100 l= 1, npar ndex = l*(l+1)/2 dx = dsqrt(abs(vhmat(ndex)*up)) i = nexofi(l) if (nvarl(i) .gt. 1) then al = alim(i) ba = blim(i) - al du1 = al + 0.5 *(dsin(x(l)+dx) +1.0) * ba - u(i) du2 = al + 0.5 *(dsin(x(l)-dx) +1.0) * ba - u(i) if (dx .gt. 1.0) du1 = ba dx = 0.5 * (abs(du1) + abs(du2)) endif werr(l) = dx 100 continue endif c global correlation coefficients if (isw(2) .ge. 1) then do 130 i= 1, npar globcc(i) = 0. k1 = i*(i-1)/2 do 130 j= 1, i k = k1 + j p(i,j) = vhmat(k) 130 p(j,i) = p(i,j) call mnvert(p,maxint,maxint,npar,ierr) if (ierr .eq. 0) then do 150 iin= 1, npar ndiag = iin*(iin+1)/2 denom = p(iin,iin)*vhmat(ndiag) if (denom.le.one .and. denom.ge.zero) then globcc(iin) = 0. else globcc(iin) = dsqrt(1.0-1.0/denom) endif 150 continue endif endif return end cdeck id>, stand. subroutine stand c ************ double precision version ************* implicit double precision (a-h,o-z) cc optional user-supplied subroutine is called whenever the cc command "standard" appears. cc return end