mnstin.f File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	mnstin (CRDBUF, IERR)

Function/Subroutine Documentation

mnstin()

subroutine mnstin	(	character, dimension(*)	CRDBUF,
			IERR
	)

Definition at line 10 of file mnstin.f.

References a, b, c, d, e, f, false, g, h, softenpik::half, i, j, m, maxp, n, o, p, parameter(), true, up(), x, xs, and z.

Referenced by mnread().

*
* $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 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
*
* $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
      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) .LT. 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) .LT. 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

Here is the call graph for this function:

Here is the caller graph for this function: