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 <aim
ecarmn = abs(fnext-aim)
ibest = 3
ecarmx = 0.
noless = 0
do 480 i= 1, 3
ecart = abs(flsb(i) - aim)
if (ecart .gt. ecarmx) then
ecarmx = ecart
iworst = i
endif
if (ecart .lt. ecarmn) then
ecarmn = ecart
ibest = i
endif
if (flsb(i) .lt. aim) noless = noless + 1
480 continue
c if at least one on each side of aim, fit a parabola
if (noless.eq.1 .or. noless.eq.2) go to 500
c if all three are above aim, third must be closest to aim
if (noless .eq. 0 .and. ibest .ne. 3) go to 950
c if all three below, and third is not best, then slope
c has again gone negative, look for positive slope.
if (noless .eq. 3 .and. ibest .ne. 3) then
alsb(2) = alsb(3)
flsb(2) = flsb(3)
go to 300
endif
c in other cases, new straight line thru last two points
alsb(iworst) = alsb(3)
flsb(iworst) = flsb(3)
dfda = (flsb(2)-flsb(1))/ (alsb(2)-alsb(1))
go to 460
c parabola fit
500 call mnpfit(alsb,flsb,3,coeff,sdev)
if (coeff(3) .le. zero) call mnwarn ('d',chere,
+ 'curvature is negative near contour line.')
determ = coeff(2)**2 - 4.*coeff(3)*(coeff(1)-aim)
if (determ .le. zero) then
call mnwarn('d',chere,'problem 2, impossible determinant')
go to 950
endif
c find which root is the right one
rt = dsqrt(determ)
x1 = (-coeff(2) + rt)/(2.*coeff(3))
x2 = (-coeff(2) - rt)/(2.*coeff(3))
s1 = coeff(2) + 2.*x1*coeff(3)
s2 = coeff(2) + 2.*x2*coeff(3)
if (s1*s2 .gt. zero) write (isyswr,'(a)') ' mncontour problem 1'
aopt = x1
if (s2 .gt. zero) aopt = x2
if (abs(aopt-alsb(inew)) .lt. tla) go to 800
c evaluate function at parabolic optimum
if (ipt .ge. maxitr) go to 950
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
ipt = ipt + 1
xpt(ipt) = aopt
ypt(ipt) = fnext
chpt(ipt)= charal(ipt:ipt)
c replace unneeded point by new one
c find nearest, farthest, (and hence middle) points,
inear = 1
anear = alsb(1)
ifar = 1
afar = alsb(1)
do 620 i= 1, 3
if (alsb(i) .lt. anear) then
anear = alsb(i)
inear = i
endif
if (alsb(i) .gt. afar) then
afar = alsb(i)
ifar = i
endif
620 continue
imid = 6 - inear - ifar
fdist = flsb(imid)-aim
if (fdist*(flsb(inear)-aim) .gt. zero) then
inew = inear
else
inew = ifar
endif
alsb(inew) = aopt
flsb(inew) = fnext
go to 500
c contour has been located, return point to mncont or minos
800 continue
iercr = 0
go to 1000
c error in the minimization
900 if (ierev .eq. 1) go to 940
go to 950
c parameter up against limit
930 iercr = 1
go to 1000
c too many calls to fcn
940 iercr = 2
go to 1000
c cannot find next point
950 iercr = 3
c in any case
1000 continue
if (ldebug) then
itoohi = 0
do 1100 i= 1, ipt
if (ypt(i) .gt. aim+up) then
ypt(i) = aim+up
chpt(i) = '+'
itoohi = 1
endif
1100 continue
chsign = 'posi'
if (xdircr .lt. zero) chsign = 'nega'
if (ke2cr .eq. 0) write (isyswr, '(2x,a,a,i3)')
+ chsign,'tive minos error, parameter ',ke1cr
if (itoohi .eq. 1) write (isyswr, '(10x,a)')
+ 'points labelled "+" were too high to plot.'
if (iercr .eq. 1) write (isyswr,'(10x,a)')
+ 'rightmost point is up against limit.'
call mnplot(xpt,ypt,chpt,ipt,isyswr,npagwd,npagln)
endif
return
end
cdeck id>, 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