doxygen/v8.037/mncntr_8f_source.html

 *
 * $Id: mncntr.F,v 1.1.1.1 1996/03/07 14:31:28 mclareni Exp $
 *
 * $Log: mncntr.F,v $
 * Revision 1.1.1.1  1996/03/07 14:31:28  mclareni
 * Minuit
 *
 *
       SUBROUTINE mncntr(FCN,KE1,KE2,IERRF,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       to print function contours in two variables, on line printer
 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
       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
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

mnwerr
subroutine mnwerr
Definition: mnwerr.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

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

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

mncntr
subroutine mncntr(FCN, KE1, KE2, IERRF, FUTIL)
Definition: mncntr.f:10

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

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

nl
!onst int nl
Definition: Zprivate.h:1

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