doxygen/v8.037/mnsimp_8f_source.html

 *
 * $Id: mnsimp.F,v 1.2 1996/03/15 18:02:54 james Exp $
 *
 * $Log: mnsimp.F,v $
 * Revision 1.2  1996/03/15 18:02:54  james
 *     Modified Files:
 * mnderi.F eliminate possible division by zero
 * mnexcm.F suppress print on STOP when print flag=-1
 *          set FVAL3 to flag if FCN already called with IFLAG=3
 * mninit.F set version 96.03
 * mnlims.F remove arguments, not needed
 * mnmigr.F VLEN -> LENV in debug print statement
 * mnparm.F move call to MNRSET to after NPAR redefined, to zero all
 * mnpsdf.F eliminate possible division by zero
 * mnscan.F suppress printout when print flag =-1
 * mnset.F  remove arguments in call to MNLIMS
 * mnsimp.F fix CSTATU so status is PROGRESS only if new minimum
 * mnvert.F eliminate possible division by zero
 *
 * Revision 1.1.1.1  1996/03/07 14:31:31  mclareni
 * Minuit
 *
 *
       SUBROUTINE mnsimp(FCN,FUTIL)
 *
 * $Id: d506dp.inc,v 1.1.1.1 1996/03/07 14:31:32 mclareni Exp $
 *
 * $Log: d506dp.inc,v $
 * Revision 1.1.1.1  1996/03/07 14:31:32  mclareni
 * Minuit
 *
 *
 *
 *
 * d506dp.inc
 *
 C ************ DOUBLE PRECISION VERSION *************
       IMPLICIT DOUBLE PRECISION (a-h,o-z)
 CC        Performs a minimization using the simplex method of Nelder
 CC        and Mead (ref. -- Comp. J. 7,308 (1965)).
 CC
 *
 * $Id: d506cm.inc,v 1.1.1.1 1996/03/07 14:31:32 mclareni Exp $
 *
 * $Log: d506cm.inc,v $
 * Revision 1.1.1.1  1996/03/07 14:31:32  mclareni
 * Minuit
 *
 *
 *
 *
 * d506cm.inc
 *
       parameter(mne=100 , mni=50)
       parameter(mnihl=mni*(mni+1)/2)
       CHARACTER*10 CPNAM
       COMMON
      1/mn7nam/ cpnam(mne)
      2/mn7ext/ u(mne)     ,alim(mne)  ,blim(mne)
      3/mn7err/ erp(mni)   ,ern(mni)   ,werr(mni)  ,globcc(mni)
      4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni)
      5/mn7int/ x(mni)     ,xt(mni)    ,dirin(mni)
      6/mn7fx2/ xs(mni)    ,xts(mni)   ,dirins(mni)
      7/mn7der/ grd(mni)   ,g2(mni)    ,gstep(mni) ,gin(mne) ,dgrd(mni)
      8/mn7fx3/ grds(mni)  ,g2s(mni)   ,gsteps(mni)
      9/mn7fx1/ ipfix(mni) ,npfix
      a/mn7var/ vhmat(mnihl)
      b/mn7vat/ vthmat(mnihl)
      c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni)
 C
       parameter(maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101)
       parameter(zero=0.0,  one=1.0,   half=0.5)
       COMMON
      d/mn7npr/ maxint ,npar   ,maxext ,nu
      e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag
      e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr
      f/mn7tit/ cfrom  ,cstatu ,ctitl  ,cword  ,cundef ,cvrsn ,covmes
      g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd
      h/mn7min/ amin   ,up     ,edm    ,fval3  ,epsi   ,apsi  ,dcovar
      i/mn7cnv/ nfcn   ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2)
      j/mn7arg/ word7(maxp)
      k/mn7log/ lwarn  ,lrepor ,limset ,lnolim ,lnewmn ,lphead
      l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt
      m/mn7rpt/ xpt(maxcpt)    ,ypt(maxcpt)
      n/mn7cpt/ chpt(maxcpt)
      o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr  ,ke2cr
       CHARACTER CTITL*50, CWORD*(maxcwd), CUNDEF*10, CFROM*8,
      +          cvrsn*6,  covmes(0:3)*22, cstatu*10, chpt*1
       LOGICAL   LWARN, LREPOR, LIMSET, LNOLIM, LNEWMN, LPHEAD
       EXTERNAL fcn,futil
       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(.LT.' START SIMPLEX MINIMIZATION.    CONVERGENCE WHEN EDM '
      +,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 .LT. 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
 C         stop after three failures
       bestx = x(i)
       dirin(i) = dirin(i) * 3.0
       aming = f
       GO TO 8
 C
 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
 C         3 failures or 6 successes or
 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)
       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 **
       cstatu = 'PROGRESS  '
       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. amin)     cstatu = 'PROGRESS  '
       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)     cstatu = 'PROGRESS  '
       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
parameter
integer npitbl real *nx parameter(n=101, npitbl=46, nx=n-1) real *8 uconst

z
nodes z
Definition: cstdatmos0.fNew2.h:93

up
block data include Zlatfit h c fitting region data data data data data d0 data data d0 data data h g *is for param c g data up(2, 1)/7.0d0/

e
dE dx *! Nuc Int sampling table e
Definition: cblkMuInt.h:130

i
nodes i
Definition: cstdatmos0.fNew2.h:93

mnprin
subroutine mnprin(INKODE, FVAL)
Definition: mnprin.f:10

xs
! constants thru Cosmos real ! if multiplied to deg radian Torad ! light velocity m sec ! infinty ! kg m2 *Togpcm2 g cm2 ! g cm2 *Tokgpm2 kg m2 ! cm *Tom m ! m *Tocm cm ! g cm3 *Tokgpm3 kg m3 ! kg m3 *Togpcm3 g cm3 ! sec *Tonsec nsec ! Tesla m ! Avogadro *A2deninv ! mfp *n * xs
Definition: Zglobalc.h:18

mnamin
subroutine mnamin(FCN, FUTIL)
Definition: mnamin.f:10

p
********************block data cblkHeavy ********************integer j data *HeavyG2symbol p
Definition: cblkHeavy.h:7

j
********************block data cblkHeavy ********************integer j data *HeavyG2symbol *data *HeavyG2code kiron data j
Definition: cblkHeavy.h:36

o
struct ob o[NpMax]
Definition: Zprivate.h:34

mndxdi
subroutine mndxdi(PINT, IPAR, DXDI)
Definition: mndxdi.f:10

mninex
subroutine mninex(PINT)
Definition: mninex.f:10

y
latitude latitude this system is used *****************************************************************! type coord sequence union map real y
Definition: Zcoord.h:25

d
dE dx *! Nuc Int sampling table d
Definition: cblkMuInt.h:130

mnsimp
subroutine mnsimp(FCN, FUTIL)
Definition: mnsimp.f:25

a
nodes a
Definition: cstdatmos0.fNew2.h:93

b
dE dx *! Nuc Int sampling table b
Definition: cblkMuInt.h:130

m
block data include Zlatfit h c fitting region data data data data data d0 data data d0 data data m
Definition: ZlatfitBD.h:35

h
dE dx *! Nuc Int sampling table h
Definition: cblkMuInt.h:130

g
dE dx *! Nuc Int sampling table g
Definition: cblkMuInt.h:130

mnrazz
subroutine mnrazz(YNEW, PNEW, Y, JH, JL)
Definition: mnrazz.f:10

e10
*************************block data cblkTracking *************************implicit none data *ExactThick *Freec *RatioToE0 *MagChgDist *TimeStructure *Truncn *Truncx data *IncMuonPolari *KEminObs *ThinSampling *EthinRatio *Generate *LpmEffect *MagPairEmin e10
Definition: cblkTracking.h:9

maxp
!onst int maxp
Definition: Zprivate.h:3

n
integer n
Definition: Zcinippxc.h:1

softenpik::half
integer, parameter half
Definition: csoftenPiK.f:108

x
! structure defining a particle at production ! Basic idea of what is to be contained in ! the particle structue is that dynamical ones should be included those derivable from the particle code ! is not included ******************************************************type fmom momentum sequence union map real e endmap map real * x
Definition: Zptcl.h:21

f
dE dx *! Nuc Int sampling table f
Definition: cblkMuInt.h:130

c
dE dx *! Nuc Int sampling table c
Definition: cblkMuInt.h:130