mncrck.f

Go to the documentation of this file.

*
* $Id: mncrck.F,v 1.1.1.1 1996/03/07 14:31:29 mclareni Exp $
*
* $Log: mncrck.F,v $
* Revision 1.1.1.1  1996/03/07 14:31:29  mclareni
* Minuit
*
*
      SUBROUTINE mncrck(CRDBUF,MAXCWD,COMAND,LNC,
     +                         MXP,   PLIST, LLIST,IERR,ISYSWR)
*
* $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
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