C     utchar.f 2.1 9/4/91
C
C
C
      SUBROUTINE   CARVAR
     I                    (LENA, CARY, LENV,
     O                     CVAR)
C
C     + + + PURPOSE + + +
C     Convert a character*1 array of size LENA
C     to a character variable of length LEN.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER       LENA, LENV
      CHARACTER*1   CARY(LENA)
      CHARACTER*(*) CVAR
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LENA   - size of input character*1 array
C     CARY   - input character array of size LENA
C     LENV   - length of output character variable
C     CVAR   - output character variable of length LENV
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     L, L1
      CHARACTER*1 BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  BLNK / ' ' /
C
C     + + + END SPECIFICATIONS + + +
C
      IF (LENA .GE. LENV) THEN
C       copy input array to output string, truncate if necessary
        DO 100 L = 1, LENV
          CVAR(L:L) = CARY(L)
 100    CONTINUE
      ELSE
C       copy input array to output string, pad with blanks as needed
        DO 200 L = 1, LENA
          CVAR(L:L) = CARY(L)
 200    CONTINUE
        L1 = LENA + 1
        DO 220 L = L1, LENV
          CVAR(L:L) = BLNK
 220    CONTINUE
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   CHDECE
     I                   (LEN,STR,
     O                    RVAL,ERRFLG)
C
C     + + + PURPOSE + + +
C     Convert a character array to its real equivalent.  The
C     real is expected to be right justified in STR.  For an
C     invalid real, ERRFLG is set to 1.  Valid characters are
C     '0' - '9', '+', '-', '.', 'D', and 'E'.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,ERRFLG
      REAL        RVAL
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     STR    - character array containing real value
C     RVAL   - real value
C     ERRFLG - flag indicating success of conversion
C              0 - successful
C              1 - unsuccessful
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
      INCLUDE 'const.inc'
C
C     + + + LOCAL VARIABLES + + +
      REAL       ERRREA
C
C     + + + FUNCTIONS + + +
      REAL       CHRDEC
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRDEC, NUMINI
C
C     + + + END SPECIFICATIONS + + +
C
C     may need to init maching dependent numeric constants (const.inc)
      CALL NUMINI
C
      ERRREA = -R0MAX
      RVAL  = CHRDEC (LEN,STR)
      ERRFLG= 0
      IF (RVAL.LE.ERRREA) THEN
C       ivalid real
        ERRFLG= 1
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   CHINTE
     I                   (LEN,STR,
     O                    IVAL,ERRFLG)
C
C     + + + PURPOSE + + +
C     Convert a character array to its integer equivalent.
C     The integer is expected to be right justified in STR.
C     For an invalid integer, ERRFLG is set to 1.
C     Valid characters are '0' - '9', '+', and '-'.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,ERRFLG,IVAL
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     STR    - character array containing an integer value
C     IVAL   - integer value
C     ERRFLG - flag indicating success of conversion
C              0 - successful
C              1 - unsuccessful
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     DIG,I,SIGN
      CHARACTER*1 CDIG
C
C     + + + FUNCTIONS + + +
      INTEGER     CHRDIG
C
C     + + + EXTERNALS + + +
      EXTERNAL    CHRDIG
C
C     + + + DATA INITIALIZATIONS + + +
C
C     + + + END SPECIFICATIONS + + +
C
      IVAL  = 0
      ERRFLG= 0
      SIGN  = 1
      I = 1
  10  CONTINUE
        CDIG = STR(I)
        IF ((CDIG.EQ.'-' .OR. CDIG.EQ.'+' .OR. CDIG.EQ.' ') .AND.
     1       IVAL.EQ.0) THEN
C         replace blank, - sign, or + sign with a 0 if no number yet
          IF (CDIG.EQ.'-') THEN
C           change sign
            SIGN = -1
          END IF
          CDIG = '0'
        END IF
        DIG = CHRDIG(CDIG)
        IVAL= IVAL* 10+ DIG
        I = I + 1
      IF (I.LE.LEN .AND. DIG.GE.0) GO TO 10
C
      IF (DIG.EQ.-1) THEN
C       invalid integer
        ERRFLG= 1
      END IF
C
      IVAL= IVAL* SIGN
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CHKSTR
     I                           (LEN,NSTR,STR1,STR2)
C
C     Search thru STR2 for a match to the character array STR1.
C     Return the array location of the match, or a zero if there
C     is no match.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,NSTR
      CHARACTER*1 STR1(LEN),STR2(LEN,NSTR)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     NSTR   - number of strings to be compared
C     STR1   - character array of size LEN to search for
C     STR2   - character array of size LEN,NSTR
C              to be searched for a match
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J,MAT
C
C     + + + END SPECIFICATIONS + + +
C
      CHKSTR = 0
      J = 1
C
  10  CONTINUE
        I = 1
        MAT = 1
  20    CONTINUE
          IF (STR1(I).NE.STR2(I,J)) MAT = 0
          I = I + 1
        IF (I.LE.LEN.AND.MAT.EQ.1) GO TO 20
        IF (MAT.EQ.1) CHKSTR = J
        J = J + 1
      IF (J.LE.NSTR.AND.CHKSTR.EQ.0) GO TO 10
C
      RETURN
      END
C
C
C
      SUBROUTINE   CHRCHR
     I                    (LEN,STR1,
     O                     STR2)
C
C     + + + PURPOSE + + +
C     Copy LEN characters from array STR1 to array STR2.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR1(LEN),STR2(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character arrays
C     STR1   - input character array
C     STR2   - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I
C
C     + + + END SPECIFICATIONS + + +
C
      DO 10 I = 1,LEN
        STR2(I) = STR1(I)
 10   CONTINUE
C
      RETURN
      END
C
C
C
      REAL   FUNCTION   CHRDEC
     I                         (LEN,STR)
C
C     + + + PURPOSE + + +
C     Convert a character array to its real equivalent.  Return
C     a -R0MAX for an invalid array.  The real is expected to
C     be right justified in the array.  Leading blanks are ignored.
C     Trailing blanks are treated as a zero.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of array
C     STR    - character array containing a real value
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
      INCLUDE 'const.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     CHKORD(6,6),ERFLG,EXPFLG,KIND,OKIND,POS,FRCFLG
      REAL        DECSGN,EXPSGN,EXPON,FRC,SUM,TEN,TVAL,ERRREA
      CHARACTER*1 DIG
C
C     + + + FUNCTIONS + + +
      REAL      RNOP
      INTEGER   CHRDIG
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRDIG, NUMINI
C
C     + + + DATA INITIALIZATIONS + + +
C
C                   DOWN OKIND, ACROSS KIND
      DATA CHKORD /
     1              1, 2, 0, 4, 0, 6,
     2              1, 2, 0, 4, 0, 6,
     3              1, 2, 3, 0, 0, 6,
     4              0, 0, 3, 4, 0, 6,
     5              1, 2, 0, 0, 0, 6,
     6              0, 0, 0, 0, 0, 0/
C
C     + + + STATEMENT FUNCTION DEFINITIONS + + +
C     No OPperation, used to keep Ryan/McFarland optimization honest
      RNOP(ERRREA) = ERRREA
C
C     + + + END SPECIFICATIONS + + +
C
C     may need to init maching dependent numeric constants (const.inc)
      CALL NUMINI
C
      ERRREA = -R0MAX
      ERFLG = 0
      EXPFLG = 0
      FRCFLG = 0
      OKIND = 6
      POS = 1
      EXPSGN = 1.0
      DECSGN = 1.0
      TEN = 10.
      FRC = 1.0
      SUM = 0.0
      EXPON = 0.0
C
  10  CONTINUE
        DIG = STR(POS)
        KIND = 0
        IF (DIG.EQ.'+') KIND = 1
        IF (DIG.EQ.'-') KIND = 2
        IF (DIG.EQ.'.') KIND = 3
        IF (DIG .EQ. 'D' .OR. DIG .EQ. 'd' .OR.
     1      DIG .EQ. 'E' .OR. DIG .EQ. 'e') KIND = 4
C       treat a blank as a zero
        IF (DIG.EQ.' ') THEN
          IF (OKIND.EQ.6) THEN
C           leading blank
            KIND = 6
          ELSE
C           not a leading blank - assume zero
            KIND = 5
            TVAL = 0
          END IF
        END IF
C
        IF (KIND.EQ.0) THEN
          TVAL = CHRDIG(DIG)
          IF (TVAL.GE.0.0) KIND = 5
        END IF
C
        IF (KIND.EQ.0) THEN
          ERFLG = 5
        ELSE
          ERFLG = CHKORD(KIND,OKIND)
        END IF
C
 40     CONTINUE
        IF (ERFLG.NE.0) THEN
C         this is a quick exit
          CHRDEC = ERRREA
          RETURN
        END IF
C
        GO TO (110,120,130,140,150,160),KIND
C
 110    CONTINUE
C         process a plus sign
          GO TO 200
C
 120    CONTINUE
C         process a minus sign
          IF (EXPFLG.EQ.0) THEN
            DECSGN = -1.0
          ELSE
            EXPSGN = -1.0
          END IF
          GO TO 200
C
 130    CONTINUE
C         process a decimal point
          IF (EXPFLG.EQ.1) THEN
            ERFLG = 3
            GO TO 40
          END IF
C
C         no fractional exponents allowed
          IF (FRCFLG.EQ.1) THEN
            ERFLG = 3
            GO TO 40
          END IF
C
C         no double decimal point
          FRCFLG = 1
          GO TO 200
C
 140    CONTINUE
C         process an exponent (E, e, D, or d)
          IF (EXPFLG.EQ.1) THEN
            ERFLG = 4
            GO TO 40
          END IF
C
C         no double exponent
          EXPFLG = 1
          GO TO 200
C
 150    CONTINUE
C         process a number
          IF (EXPFLG.EQ.0) THEN
            IF (FRCFLG.EQ.0) THEN
              SUM = (SUM* TEN) + TVAL
            ELSE
              FRC = FRC/ TEN
              FRC = RNOP(FRC)
              SUM = SUM + (FRC* TVAL)
            END IF
          ELSE
            EXPON = (EXPON* TEN) + TVAL
          END IF
          GO TO 200
C
 160    CONTINUE
C         process a leading blank
          GO TO 200
C
 200    CONTINUE
C       repeat until finished
        OKIND = KIND
        POS = POS + 1
      IF (POS.LE.LEN) GO TO 10
      CHRDEC = DECSGN* SUM* TEN** (EXPSGN* EXPON)
C
      RETURN
      END
C
C
C
      DOUBLE PRECISION   FUNCTION   CHRDPR
     I                                    (LEN,STR)
C
C     + + + PURPOSE + + +
C     Convert a character array to its double precision equivalent.
C     Return a -D0MAX for an invalid array.  The double precision
C     is expected to be right justified in the array.  Leading blanks
C     are ignored.  Trailing blanks are treated as a zero.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of array
C     STR    - character array containing a real value
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
      INCLUDE 'const.inc'
C
C     + + + LOCAL VARIABLES + + +
      REAL*8      DECSGN,EXPSGN,EXPON,FRC,SUM,TEN,TVAL
      INTEGER     CHKORD(6,6),ERFLG,EXPFLG,KIND,OKIND,POS,FRCFLG
      CHARACTER*1 DIG
      DOUBLE PRECISION  ERRREA
C
C     + + + FUNCTIONS + + +
      INTEGER   CHRDIG
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRDIG, NUMINI
C
C                   DOWN OKIND, ACROSS KIND
      DATA CHKORD /
     1              1, 2, 0, 4, 0, 6,
     2              1, 2, 0, 4, 0, 6,
     3              1, 2, 3, 0, 0, 6,
     4              0, 0, 3, 4, 0, 6,
     5              1, 2, 0, 0, 0, 6,
     6              0, 0, 0, 0, 0, 0/
C
C     + + + END SPECIFICATIONS + + +
C
C     may need to init maching dependent numeric constants (const.inc)
      CALL NUMINI
C
      ERRREA = -D0MAX
      ERFLG = 0
      EXPFLG = 0
      FRCFLG = 0
      OKIND = 6
      POS = 1
      EXPSGN = 1.0
      DECSGN = 1.0
      TEN = 10.
      FRC = 1.0
      SUM = 0.0
      EXPON = 0.0
C
  10  CONTINUE
        DIG = STR(POS)
        KIND = 0
        IF (DIG.EQ.'+') KIND = 1
        IF (DIG.EQ.'-') KIND = 2
        IF (DIG.EQ.'.') KIND = 3
        IF (DIG .EQ. 'D' .OR. DIG .EQ. 'd' .OR.
     1      DIG .EQ. 'E' .OR. DIG .EQ. 'e') KIND = 4
C       treat a blank as a zero
        IF (DIG.EQ.' ') THEN
          IF (OKIND.EQ.6) THEN
C           leading blank
            KIND = 6
          ELSE
C           not a leading blank - assume zero
            KIND = 5
            TVAL = 0
          END IF
        END IF
C
        IF (KIND.EQ.0) THEN
          TVAL = CHRDIG(DIG)
          IF (TVAL.GE.0.0) KIND = 5
        END IF
C
        IF (KIND.EQ.0) THEN
          ERFLG = 5
        ELSE
          ERFLG = CHKORD(KIND,OKIND)
        END IF
C
 40     CONTINUE
        IF (ERFLG.NE.0) THEN
C         this is a quick exit
          CHRDPR = ERRREA
          RETURN
        END IF
C
        GO TO (110,120,130,140,150,160),KIND
C
 110    CONTINUE
C         process a plus sign
          GO TO 200
C
 120    CONTINUE
C         process a minus sign
          IF (EXPFLG.EQ.0) THEN
            DECSGN = -1.0
          ELSE
            EXPSGN = -1.0
          END IF
          GO TO 200
C
 130    CONTINUE
C         process a decimal point
          IF (EXPFLG.EQ.1) THEN
            ERFLG = 3
            GO TO 40
          END IF
C
C         no fractional exponents allowed
          IF (FRCFLG.EQ.1) THEN
            ERFLG = 3
            GO TO 40
          END IF
C
C         no double decimal point
          FRCFLG = 1
          GO TO 200
C
 140    CONTINUE
C         process an exponent (E, e, D, or d)
          IF (EXPFLG.EQ.1) THEN
            ERFLG = 4
            GO TO 40
          END IF
C
C         no double exponent
          EXPFLG = 1
          GO TO 200
C
 150    CONTINUE
C         process a number
          IF (EXPFLG.EQ.0) THEN
            IF (FRCFLG.EQ.0) THEN
              SUM = (SUM* TEN) + TVAL
            ELSE
              FRC = FRC/ TEN
              SUM = SUM + (FRC* TVAL)
            END IF
          ELSE
            EXPON = (EXPON* TEN) + TVAL
          END IF
          GO TO 200
C
 160    CONTINUE
C         process a leading blank
          GO TO 200
C
 200    CONTINUE
C       repeat until finished
        OKIND = KIND
        POS = POS + 1
      IF (POS.LE.LEN) GO TO 10
      CHRDPR = DECSGN* SUM* TEN** (EXPSGN* EXPON)
C
      RETURN
      END
C
C
C
      SUBROUTINE   CHRDEL
     I                    (LEN,POS,
     M                     STRING)
C
C     + + + PURPOSE + + +
C     Delete the character in array position POS and shift
C     the rest of the array left one position.  The last
C     character in the array is set to blank.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,POS
      CHARACTER*1 STRING(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     POS    - array position of the character to be deleted from STRING
C     STRING - character array of size LEN
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I
C
C     + + + END SPECIFICATIONS + + +
C
      IF (POS.LT.LEN) THEN
C       no problem with array dimensions
        DO 10 I = POS,LEN-1
          STRING(I) = STRING(I + 1)
 10     CONTINUE
        STRING(LEN) = ' '
      ELSE IF (POS.EQ.LEN) THEN
C       just delete last character
        STRING(LEN) = ' '
      END IF
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CHRDIG
     I                           (CHR)
C
C     Convert a single character to an integer. Valid characters
C     are '0' - '9'.  Return -1 for an invalid character.
C
C     + + + DUMMY ARGUMENTS + + +
      CHARACTER*1 CHR
C
C     + + + ARGUMENT DEFINITIONS + + +
C     CHR    - a single character
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I
      CHARACTER*1 TDIG(10)
C
C     + + + DATA INITIALIZATIONS + + +
      DATA TDIG  /'0','1','2','3','4','5','6','7','8','9'/
C
C     + + + END SPECIFICATIONS + + +
C
      CHRDIG = -1
      I = 1
  10  CONTINUE
        IF (CHR.EQ.TDIG(I)) CHRDIG = I- 1
        I = I + 1
      IF (CHRDIG.EQ.-1.AND.I.LE.10) GO TO 10
C
      RETURN
      END
C
C
C
      SUBROUTINE   CHRINS
     I                    (LEN,COL,CHAR,
     M                     STRING)
C
C     + + + PURPOSE + + +
C     Insert the character CHAR into position COL in the
C     array STRING.  First shift the characters in
C     positions COL thru LEN-1 one position to the right.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,COL
      CHARACTER*1 CHAR,STRING(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - output length of character string
C     COL    - position in STRING that CHAR is to be inserted
C     CHAR   - character to be inserted in STRING
C     STRING - character string
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J
C
C     + + + END SPECIFICATIONS + + +
C
      IF (COL.EQ.LEN) THEN
C       just fill last position
        STRING(LEN) = CHAR
      ELSE IF (COL.EQ.1 .AND. LEN.EQ.2) THEN
C       trap weird dimension case
        STRING(2) = STRING(1)
        STRING(1) = CHAR
      ELSE
C       all ok
        DO 10 I = COL,LEN-1
          J = LEN + COL- I- 1
          STRING(J+1) = STRING(J)
 10     CONTINUE
        STRING(COL) = CHAR
      END IF
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CHRINT
     I                           (LEN,STR)
C
C     + + + PURPOSE + + +
C     Convert a character array to its integer equivalent.  Return
C     a 0 for an invalid array.  The integer is expected to be
C     right justified in the array.  Leading blanks are ignored.
C     Trailing blanks are treated as a zero.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     STR    - character array containing an integer value
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     ERRINT
C
C     + + + FUNCTIONS + + +
      INTEGER     CRINTE
C
C     + + + EXTERNALS + + +
      EXTERNAL   CRINTE
C
C     + + + END SPECIFICATIONS + + +
C
      ERRINT= 0
      CHRINT= CRINTE(ERRINT,LEN,STR)
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CKNBLK
     I                           (LEN,CBUF)
C
C     + + + PURPOSE + + +
C     Check character array CBUF for all blanks.  Return
C     a zero if all blanks, otherwise return a one.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 CBUF(LEN)
C
C     + + + ARGUMENT DEFINITION + + +
C     LEN    - size of character array
C     CBUF   - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J
C
C     + + + END SPECIFICATIONS + + +
C
      J = 0
      DO 10 I = 1,LEN
        IF (CBUF(I) .NE. ' ') J = 1
 10   CONTINUE
C
      CKNBLK = J
C
      RETURN
      END
C
C
C
      SUBROUTINE   COPYC
     I                   (LEN, ZIP,
     O                    X)
C
C     + + + PURPOSE + + +
C     Copy the character array ZIP of size LEN to
C     the character array X of size LEN.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 ZIP(LEN),X(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character arrays
C     ZIP    - input character array
C     X      - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     L
C
C     + + + END SPECIFICATIONS + + +
C
      DO 100 L= 1, LEN
        X(L)= ZIP(L)
 100  CONTINUE
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CRINTE
     I                           (ERRINT,LEN,STR)
C
C     + + + PURPOSE + + +
C     Convert a character array to its integer equivalent.
C     The integer is expected to be right justified in STR.
C     For an invalid integer, return ERRINT.  Valid characters
C     are '0' - '9', '+', '-', '.', 'D', and 'E'.  Leading
C     blanks are ignored.  Trailing blanks are treated as 0.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER*4     ERRINT,LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     ERRINT - value to be returned fo an invalid array
C     LEN    - size of character array
C     STR    - character array containing an integer value
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     DIG,I,SIGN,ITMP
      CHARACTER*1 CDIG
      LOGICAL     NEARMAX
C
C     + + + FUNCTIONS + + +
      INTEGER     CHRDIG
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRDIG
C
C     + + + END SPECIFICATIONS + + +
C
      ITMP= 0
      SIGN= 1
      I   = 0
      NEARMAX = .FALSE.
  10  CONTINUE
        I   = I + 1
        CDIG= STR(I)
C       replace a blank with a zero
        IF ((CDIG.EQ.'-' .OR. CDIG.EQ.'+' .OR. CDIG.EQ.' ') .AND.
     1       ITMP.EQ.0) THEN
C         replace blank, - sign, or + sign with a 0 if no number yet
          IF (CDIG.EQ.'-') THEN
C           change sign
            SIGN= -1
          END IF
          CDIG = '0'
        END IF
        DIG = CHRDIG(CDIG)
        IF (NEARMAX) THEN
          IF ((DIG .GT. 8) .OR. (DIG .EQ. 8 .AND. SIGN .EQ. 1)) THEN
C            the last digit cannot be greater than 8, and it can only
C            be 8 if the number is negative.
             I = I - 1
             GO TO 20
          END IF
        END IF
        ITMP= ITMP* 10+ DIG
        IF (I.LT.LEN .AND. DIG.GE.0) THEN
          IF (ITMP .EQ. 214748364) THEN
C            right at the border, an additional digit may be possible
             NEARMAX = .TRUE.
          ELSE IF (ITMP .GT. 214748364) THEN
C            no room for another digit, no matter what it is
             GO TO 20
          END IF
          GO TO 10
        END IF
C
 20   CONTINUE
C
      IF (DIG.EQ.-1 .OR. I.LT.LEN) THEN
C       bad conversion
        CRINTE = ERRINT
      ELSE
C       ok conversion
        CRINTE = ITMP* SIGN
      END IF
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CRINTX
     I                           (LEN,STR)
C
C     + + + PURPOSE + + +
C     Convert a character array to its integer equivalent.
C     The integer is expected to be right justified in STR.
C     For an invalid integer, -999 is returned.  Valid characters
C     are '0' - '9', '+', and '-' .  Leading blanks are ignored.
C     Trailing blanks are treated as 0.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     STR    - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     ERRINT
C
C     + + + FUNCTIONS + + +
      INTEGER     CRINTE
C
C     + + + EXTERNALS + + +
      EXTERNAL   CRINTE
C
C     + + + END SPECIFICATIONS + + +
C
      ERRINT= -999
      CRINTX= CRINTE(ERRINT,LEN,STR)
C
      RETURN
      END
C
C
C
      SUBROUTINE   CTRSTR
     I                    (LEN,
     M                     TITLE)
C
C     + + + PURPOSE + + +
C     Center the characters within the array TITLE.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 TITLE(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array, 1 <= LEN <= 132
C     TITLE  - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     L,IE,IS,I,J,K,B,TLEN
      CHARACTER*1 BUFF(132),BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA BLNK/' '/
C
C     + + + END SPECIFICATIONS + + +
C
      TLEN = LEN
      IF (TLEN.GT.132) TLEN = 132
      I = 0
 10   CONTINUE
        I = I + 1
      IF (TITLE(I).EQ.BLNK.AND.I.LT.TLEN) GO TO 10
      IS = I
C     found beginning of non-blanks
C
      I = TLEN + 1
 20   CONTINUE
        I = I - 1
      IF (TITLE(I).EQ.BLNK.AND.I.GT.1) GO TO 20
      IE = I
C     found end of non-blanks
C
      IF (IE.GE.IS) THEN
C       title not all blanks
        L = IE - (IS-1)
        B = (TLEN-L)/2
        DO 30 I = 1,TLEN
          BUFF(I) = TITLE(I)
          TITLE(I) = BLNK
 30     CONTINUE
        DO 40 I = 1,L
          J = B + I
          K = IS + I - 1
          TITLE(J) = BUFF(K)
 40     CONTINUE
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   CVARAR
     I                    (LENV, CVAR, LENA,
     O                     CARY)
C
C     + + + PURPOSE + + +
C     Convert a character variable of length LENV to
C     a character array of size LENA.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER       LENV, LENA
      CHARACTER*(*) CVAR
      CHARACTER*1   CARY(LENA)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LENV   - length of input character variable
C     CVAR   - input character variable of length LENV
C     LENA   - size of output character array
C     CARY   - output character array of size LENA
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   L, L1
      CHARACTER*1 BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  BLNK  / ' ' /
C
C     + + + END SPECIFICATIONS + + +
C
      IF (LENV .GE. LENA) THEN
C       copy variable to array, truncate if needed
        DO 100 L = 1, LENA
          CARY(L) = CVAR(L:L)
 100    CONTINUE
      ELSE
C       copy variable to array, padding with blanks
        DO 200 L = 1, LENV
          CARY(L) = CVAR(L:L)
 200    CONTINUE
        L1 = LENV + 1
        DO 220 L = L1, LENA
          CARY(L) = BLNK
 220    CONTINUE
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   DATCHR
     I                    (YR, MO, DY,
     O                     OLEN, DBUFF)
C
C     + + + PURPOSE + + +
C     Put a date into a character array.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     YR, MO, DY, OLEN
      CHARACTER*1 DBUFF(10)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     YR     - year
C     MO     - month
C     DY     - day
C     OLEN   - actual output size of character array
C     DBUFF  - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     LEN, LOC, JUST
      CHARACTER*1 SLSH,BLNK
C
C     + + + EXTERNALS + + +
      EXTERNAL    ZIPC, INTCHR
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  SLSH,BLNK  / '/',' ' /
C
C     + + + END SPECIFICATIONS + + +
C
      JUST= 1
      LOC = 1
      LEN = 10
      CALL ZIPC (LEN,BLNK,DBUFF)
      LEN = 4
      CALL INTCHR( YR, LEN, JUST, OLEN, DBUFF(LOC) )
      LOC = LOC + OLEN
      IF(MO .GT. 0  .AND.  MO .LT. 13) THEN
        DBUFF(LOC) = SLSH
        LOC = LOC + 1
        LEN = 2
        CALL INTCHR( MO, LEN, JUST, OLEN, DBUFF(LOC) )
        LOC = LOC + OLEN
        IF(DY .GT. 0  .AND. DY .LT. 32) THEN
          DBUFF(LOC) = SLSH
          LOC = LOC + 1
          LEN = 2
          CALL INTCHR( DY, LEN, JUST, OLEN, DBUFF(LOC) )
          LOC = LOC + OLEN
        END IF
      END IF
      OLEN = LOC - 1
C
      RETURN
      END
C
C
C
      SUBROUTINE   DATLST
     I                    (DATE,
     O                     DSTRNG,LEN,ERRCOD)
C
C     + + + PURPOSE + + +
C     Put DATE into the character array DSTRNG in the
C     format 1986 FEB. 14 10:30:00.  If hours, minutes,
C     and seconds are all zero, the format is 1986 FEB. 14.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     DATE(6),LEN,ERRCOD
      CHARACTER*1 DSTRNG(21)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DATE   - date
C     DSTRNG - output character array
C     LEN    - actual number of characters output to character array
C     ERRCOD - flag indicating valid date
C              0 - valid date
C              1 - invalid year
C              2 - invalid month
C              3 - invalid day
C              4 - invalid hour
C              5 - invalid minute
C              6 - invalid second
C              the ERRCOD for the smallest invalid date element is
C              returned, if day and hour are both invalid, a 4 is
C              returned
C
C     + + +   LOCAL VARIABLES   + + +
      INTEGER     JUST,OLEN,LOC,MO,J
      CHARACTER*1 MOCHAR(39),BLNK
C
C     + + + FUNCTIONS + + +
      INTEGER     DAYMON
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRCHR, DAYMON, INTCHR, ZIPC
C
C     + + + DATA INITIALIZATIONS + + +
      DATA MOCHAR/'J','A','N',    'F','E','B',    'M','A','R',    'A',
     1            'P','R',    'M','A','Y',    'J','U','N',    'J','U',
     2            'L',    'A','U','G',    'S','E','P',    'O','C','T',
     3                'N','O','V',    'D','E','C',    'E','R','R'    /
      DATA BLNK  /' '/
C
C     + + + END SPECIFICATIONS + + +
C
C     check values
      J= 21
      CALL ZIPC (J,BLNK,DSTRNG)
      ERRCOD = 0
C
      IF (DATE(1).LE.0.OR.DATE(1).GT.2100) ERRCOD = 1
      IF (DATE(2).LE.0.OR.DATE(2).GT.12) ERRCOD = 2
C
      IF (ERRCOD.EQ.0) THEN
        IF (DATE(3).LE.0.OR.DATE(3).GT.DAYMON(DATE(1),DATE(2)))
     1                                                 ERRCOD = 3
        IF (DATE(4).LT.0.OR.DATE(4).GT.24) ERRCOD = 4
        IF (DATE(5).LT.0.OR.DATE(5).GT.60) ERRCOD = 5
        IF (DATE(6).LT.0.OR.DATE(6).GT.60) ERRCOD = 6
C
      END IF
      IF (ERRCOD.EQ.0) THEN
C
C       put date in character array
C       add year
        JUST = 1
        LEN = 4
        LOC = 1
        IF (DATE(1).GT.9999.OR.DATE(1).LT.-999) DATE(1) = 9999
        CALL INTCHR (DATE(1),LEN,JUST,OLEN,DSTRNG(LOC))
        LOC = LOC + OLEN + 1
C
C       add month
        LEN = 3
        MO = 3*(DATE(2)-1) + 1
        IF (MO.LT.1.OR.MO.GT.34) MO = 37
        CALL CHRCHR (LEN,MOCHAR(MO),DSTRNG(LOC))
        LOC = LOC + LEN + 1
C
C       add day
        LEN = 2
        IF (DATE(3).GT.99.OR.DATE(3).LT.-9) DATE(3) = 99
        CALL INTCHR (DATE(3),LEN,JUST,OLEN,DSTRNG(LOC))
        LOC = LOC + OLEN + 1
C
C       add hour
        IF (DATE(4)+DATE(5)+DATE(6) .GT. 0) THEN
          LEN = 2
          IF (DATE(4).GT.99.OR.DATE(4).LT.0) DATE(4) = 99
          IF (DATE(4).LT.10) LEN = 1
          IF (LEN.EQ.1) THEN
            DSTRNG(LOC)= '0'
            LOC = LOC + 1
          END IF
          CALL INTCHR (DATE(4),LEN,JUST,OLEN,DSTRNG(LOC))
          LOC = LOC + OLEN
C
C         add colon
          DSTRNG(LOC)= ':'
          LOC = LOC + 1
C
C         add minute
          LEN = 2
          IF (DATE(5).GT.99.OR.DATE(5).LT.0) DATE(5) = 99
          IF (DATE(5).LT.10) LEN = 1
          IF (LEN.EQ.1) THEN
            DSTRNG(LOC)= '0'
            LOC = LOC + 1
          END IF
          CALL INTCHR (DATE(5),LEN,JUST,OLEN,DSTRNG(LOC))
          LOC = LOC + OLEN
C
C         add colon
          DSTRNG(LOC)= ':'
          LOC = LOC + 1
C
C         add second
          LEN = 2
          IF (DATE(6).GT.99.OR.DATE(6).LT.0) DATE(6) = 99
          IF (DATE(6).LT.10) LEN = 1
          IF (LEN.EQ.1) THEN
            DSTRNG(LOC)= '0'
            LOC = LOC + 1
          END IF
          CALL INTCHR (DATE(6),LEN,JUST,OLEN,DSTRNG(LOC))
          LOC = LOC + OLEN + 1
        END IF
        LEN = LOC - 2
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   DECCHR
     I                    (REAIN, LENGTH,
     M                     JUST,
     O                     JLEN, STR)
C
C
C     + + + PURPOSE + + +
C     This routine converts a real number to a character string.
C     The number is right justified in the string if the flag
C     JUST is zero or if the number requires an exponent,
C     otherwise it is left justified.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER      LENGTH, JUST, JLEN
      REAL         REAIN
      CHARACTER*1  STR(LENGTH)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     REAIN  - real value to be converted to a character string
C     LENGTH - available length for output character string
C     JUST   - output justification
C              0 - right justified
C              1 - left justified
C              will be forced to 0 if an exponent is required
C     JLEN   - actual length of output character string
C     STR    - output character string
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
      INCLUDE 'const.inc'
C 
C     + + + LOCAL VARIABLES + + + 
      INTEGER      I0, I1, I2, I, J, K, L, M, PREC, EXPO, WHDIGS, 
     $             EXDIGS, FDIGS, NOCNT, KLEN
      REAL         R1, R2, R3, ARTMP, RSUB, MINFIX, MAXFIX, X
      CHARACTER*1  FMTBUF(12), BUF(79),  ZERO,  BLNK,  POINT,  STAR
      CHARACTER*12 FMT
      CHARACTER*79 BUFSTR
      LOGICAL      FLOAT, FRAC, NEG, KILL, NOFIT
C
C     + + + LOCAL DEFINITIONS + + +
C     NOCNT  - for real values less than 1.0, NOCNT is the number of
C              zeros immediately following the decimal point (which
C              "don't count" in terms of the number of significant
C              digits representable by the machine); for real values
C              greater than or equal to 1.0, NOCNT = 0
C
C     + + + EQUIVALENCES + + +
      EQUIVALENCE (BUF,BUFSTR)
      EQUIVALENCE (FMT,FMTBUF)
C
C     + + + FUNCTIONS + + +
      INTEGER      RWDIGS
      REAL         FPART, RNOP
      LOGICAL      NONZER, NZFRAC
C
C     + + + INTRINSICS + + +
      INTRINSIC    IABS, ABS, ALOG10, REAL, LEN, INDEX, 
     $             INT, AINT, ANINT, NINT
C
C     + + + EXTERNALS + + +
      EXTERNAL     INTCHR, NUMINI, RWDIGS
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  I0, I1, I2, ZERO, BLNK, POINT, STAR
     .    /  0,  1,  2,  '0',  ' ',   '.',  '*' /
C
C     + + + STATEMENT FUNCTION DEFINITIONS + + +
C     absolute value of the FRACtional PART (of a real number)
      FPART(X)  = ABS(X) - ABS(AINT(X))
C     NON-ZERo real number? - true or false  N.B. X should not be < 0.0
      NONZER(X) = X .GT. 0.0
C     Non-Zero FRACtional part of a real number? - true or false
      NZFRAC(X) = NONZER(FPART(X))
C     number of Whole DIGitS - for X > 0;
C     double precision needed in the following to ensure correct calc.
C     of log for DG/UX
Cmyg  WDIGS(X)  = IDINT(DLOG10(DBLE(X*RP1MIN))) + 1 
C     to keep Ryan/McFarland optimization honest
      RNOP(X) = X
C
C     + + + END SPECIFICATIONS + + +
C
C     may need to init machine-dependent numeric constants (const.inc)
      CALL NUMINI
C
C     save time with the common case of REAIN .eq. 0
      IF (ABS(REAIN) .LE. R0MIN) THEN
         IF (LENGTH .GE. 3) THEN
            BUFSTR = '0.0'
         ELSE IF (LENGTH .EQ. 2) THEN
            BUFSTR = '0.'
         ELSE IF (LENGTH .EQ. 1) THEN
            BUFSTR = '0'
         ELSE
            NOFIT = .TRUE.
         END IF
      ELSE
C
C        the number of decimal digits of precision offered can be found
C        in the variable RPREC of the ICONST common block.
         PREC = RPREC
C
C        is the number negative?  set NEG and define MAXFIX/MINFIX
         IF (REAIN .LT. 0.0) THEN
            NEG = .TRUE.
            MAXFIX = 10.0**(LENGTH-1)
            MINFIX = 1.0/10.0**(LENGTH-1)
         ELSE
            NEG = .FALSE.
            MAXFIX = 10.0**LENGTH
            MINFIX = 1.0/10.0**LENGTH
         END IF
C
C        this copy of the absolute value of the number is used frequently
         ARTMP = ABS(REAIN)
C
C        using scientific notation, how many digits will be in the exponent?
C        the answer will be in EXDIGS.
         R1 = ALOG10(ARTMP*RP1MIN)
C        (RNOP must be used to keep Ryan/McFarland optimization from causing
C        problems.  If RNOP is not used, and RM optimization is turned on,
C        then R1 is left on the stack as an 80-bit number instead of being
C        popped and pushed.)
         R1 = RNOP(R1)
         EXPO = INT(R1)
         IF (R1 .LT. 0.0) THEN
            IF (NZFRAC(R1)) THEN
               EXPO = EXPO - 1
            END IF
         END IF
         IF (EXPO .EQ. 0) THEN
            EXDIGS = 1
         ELSE
            EXDIGS = INT(ALOG10(REAL(IABS(EXPO))*RP1MIN)) + 1
         END IF
C
C        how many digits in the whole part of the number?
         IF (ARTMP .GE. 1.0) THEN
            WHDIGS = RWDIGS(ARTMP)
         ELSE
C           one digit to allow room for 0
            WHDIGS = 1
         END IF
C
         IF (ARTMP.LT.MINFIX .OR. ARTMP.GT.MAXFIX 
     $       .OR. WHDIGS.GT.PREC) THEN
C           use scientific notation
            FLOAT = .FALSE.
C           force right justification with scientific notation
            JUST = 0
         ELSE
C           use floating point notation
            FLOAT  = .TRUE.
C           does the number have a non-zero fractional part?
            FRAC   = NZFRAC(REAIN)
C           here, in the context of a floating point number, EXDIGS is
C           a count of EXtra whole DIGits (not digits in the exponent).
            EXDIGS = 0
            NOCNT  = 0
            IF (FRAC) THEN
C              if the fractional part were rounded, would the number of
C              of whole digits increase?  (EXtra whole DIGitS)
               IF (ANINT(FPART(REAIN)) .GT. 0.0) THEN
C                  IF ((ARTMP+1.0) .GE. 1.0) THEN
                     IF (RWDIGS(ARTMP+1.0) .GT. WHDIGS) EXDIGS = 1
C                  END IF
               END IF
               IF (ARTMP .LT. 1.0) THEN
C                 since there is a non-zero fractional part (FRAC = TRUE),
C                 and the absolute value of the number is less than 1.0,
C                 how many consecutive zeros immediately follow the decimal
C                 point?  The NOCNT (no count) zeros don't count against the
C                 precision available.
                  R1 = ABS(ALOG10(ARTMP*RP1MIN))
                  IF (NZFRAC(R1)) THEN
                     NOCNT = INT (R1)
                  ELSE
                     NOCNT = INT (R1) - 1
                  END IF
               END IF
            END IF
         END IF
C
         IF (FLOAT) THEN
C           using floating point notation
            RSUB = REAIN
C
C           first, assume it's not negative, taking into account the '.':
            FDIGS = LENGTH - (WHDIGS + 1)
            IF (FDIGS-NOCNT .GT. PREC) FDIGS = PREC+NOCNT
C           if it is negative, there will be less room for fractional digits
            IF (NEG) FDIGS = FDIGS - 1
C           if the number of WHole digits is one, it might just be a zero
C           in which case, for purposes of precision, we can consider the
C           number of whole digits to be zero.
            IF (WHDIGS .EQ. 1) THEN
C              if the whole number IS a zero, then maybe it would be better
C              to add an extra digit of precision to the fraction rather than
C              display the zero whole number.  However, don't do this if
C              the precision would be exceeded.
               IF (AINT(ARTMP) .LE. 0.0 .AND. FDIGS.LT.PREC+NOCNT) THEN
                  WHDIGS = 0
C                 we could just add that extra digit of precision to the
C                 fraction, but if it's just zero too, it looks better to
C                 keep the zero to the left of the decimal.
                  IF (FRAC) THEN
C                    r1 gets the number that we had planned to display, but
C                    raised to a power of 10 such that it is a whole number.
                     R1 = ANINT(ARTMP*10.0**FDIGS)
C                    r2 gets a fraction representing digits which we had
C                    not planned to display and r3 is that fraction times 10.
                     R2 = (ARTMP*10.0**FDIGS) - R1
                     R3 = R2*10
C                    now, if 1) the number we were not going to display is,
C                    when rounded, non-zero, or if 2) the number passed in
C                    is negative, but everything we had planned on displaying
C                    was zero, then we add the extra digit of precision.
C                    in the first case, we just end up dropping the zero to
C                    the left of the decimal and adding an extra digit of
C                    precision; in the second case, the extra digit of
C                    precision is added only if the digits that were to be
C                    displayed previously were all zeros and the number
C                    itself is negative, so if the extra digit is zero, it
C                    is displayed to make up for the fact that the negative
C                    sign (for which room has been given) won't be displayed,
C                    but if the extra digit is non-zero, the negative sign
C                    will be displayed and the zero before the decimal will
C                    be lost.
                     IF (NINT(R3).NE.0 .OR. 
     $                  (NEG .AND. R1.LE.1.0E-20)) THEN
                           FDIGS  = FDIGS + 1
                     END IF
                  END IF
C                 if nocnt, the number of zero digits immediately
C                 following the decimal point (which don't count against the
C                 number of digits of precision representable by the machine),
C                 is greater than zero (this can only be the case if the
C                 absolute value of the number is less than one, as here)
C                 then we must ensure that the number of digits displayed
C                 does not exceed the actual machine precision
               END IF
            END IF
C
            IF ((WHDIGS + FDIGS - NOCNT) .GT. PREC) THEN
               FDIGS = PREC - WHDIGS + NOCNT
            END IF
C
            NOFIT = .FALSE.
            FMT = '(F  .  )'
            IF (FDIGS .GT. 0) THEN
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH,FDIGS
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE IF (FDIGS .EQ. 0) THEN
               RSUB = ANINT (RSUB)
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH,FDIGS
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE IF (FDIGS .EQ. -1) THEN
               RSUB = ANINT (RSUB)
               FDIGS = 0
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH+1,FDIGS
               I = LENGTH + 1
               CALL INTCHR (I,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE
               NOFIT = .TRUE.
            END IF
C
         ELSE
C           using scientific notation
            RSUB  = REAIN
            NOFIT = .FALSE.
            IF (NEG) THEN
               IF (EXDIGS+5 .LE. LENGTH) THEN
                  FDIGS = LENGTH-(EXDIGS+5)
                  IF (FDIGS+1 .GT. PREC) FDIGS = PREC - 1
               ELSE
                  NOFIT = .TRUE.
               END IF
            ELSE
               IF (EXDIGS+4 .LE. LENGTH) THEN
                  FDIGS = LENGTH-(EXDIGS+4)
                  IF (FDIGS+1 .GT. PREC) FDIGS = PREC - 1
               ELSE
                  NOFIT = .TRUE.
               END IF
            END IF
C            expensive internal write replaced, but this is what it did
C            IF (.NOT. NOFIT) WRITE(FMT,95) LENGTH,FDIGS,EXDIGS
            IF (.NOT. NOFIT) THEN
               FMT = '(1PE  .  E )'
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(5))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(8))
               CALL INTCHR (EXDIGS,I1,I0,KLEN,FMTBUF(11))
            END IF
         END IF
C
C        here we either put asterisks or use 'write' to convert the number
         IF (NOFIT) THEN
            JLEN = 0
            DO 400 I = 1,LENGTH
               BUF(I) = STAR
  400       CONTINUE
         ELSE
C           some compilers don't like blanks embedded in the format string
C           as they are now, so first squeeze it together, and then use it
C           to format the given number.
            I = INDEX(FMT,BLNK)
            IF (I .GT. 0) THEN
               J = I
               L = LEN(FMT)
               DO 420 K = I,L
                  IF (FMTBUF(K) .NE. BLNK) THEN
                     FMTBUF(J) = FMTBUF(K)
                     J = J + 1
                  END IF
  420          CONTINUE
               DO 430 K = J,L
                  FMTBUF(K) = BLNK
  430          CONTINUE
            END IF
C
            I = INDEX(FMT,BLNK)
            IF (I .EQ. 0) I = LEN(FMT)
C
            WRITE(BUFSTR,FMT(1:I)) RSUB
C
         END IF
C
C        in either form, at most 1 trailing zero should be left.
C        make J point to the '.' if there is one
         J = INDEX (BUFSTR,POINT)
         IF (FLOAT) THEN
            IF (J .NE. 0) THEN
C              kludge to change " .0" to "0.0" in some cases on some 'chines
               IF ((J-1) .GT. 0) THEN
                  IF (BUF(J-1) .EQ. BLNK) THEN
                     BUF(J-1) = ZERO
                  END IF
               END IF
C              we don't want to truncate any zeros if there's no '.'
C              make K point to the last zero (if there is one)
               I = 0
               K = 0
  510          CONTINUE
               I = INDEX (BUFSTR(K+1:79),ZERO)
               IF (I .NE. 0) THEN
                  K = K + I
                  GO TO 510
               END IF
               KILL = .TRUE.
               IF (K .NE. 79) THEN
C                 only kill zeros that are not significant.  if the last
C                 zero is followed by something other than a blank,
C                 then you can't get rid of it.
                  IF (BUF(K+1) .NE. BLNK) KILL = .FALSE.
               END IF
               IF (K .GT. J+1 .AND. KILL) THEN
C                 only truncate zeros if they're to the right of the decimal
C                 and don't get rid of a zero that is immediately to the
C                 right of the decimal point.
                  DO 520 I = K,J+2,-1
                     IF (BUF(I) .EQ. ZERO) THEN
                        BUF(I) = BLNK
                     ELSE
C                       once a non-zero is found, get out of the loop
                        GO TO 525
                     END IF
  520             CONTINUE
  525             CONTINUE
               END IF
            END IF
         ELSE
C           get rid of trailing zeros in scientific notation
            IF (J .NE. 0) THEN
C              we don't won't to truncate any zeros if there's no '.'
C              make L point to the 'E'
               L = INDEX (BUFSTR,'E')
               IF (L .NE. 0) THEN
C                 make K point to the last digit before the 'E'
                  K = L - 1
                  IF (K .GT. J+1) THEN
C                    only truncate zeros between '.' and 'E', and don't
C                    get rid of the zero (if there is one) immediately to the
C                    right of the decimal.
                     M = J+2
                     DO 620 I = K,J+2,-1
                        IF (BUF(I) .EQ. ZERO) THEN
C                          don't truncate the last trailing zero
                           BUF(I) = BLNK
                        ELSE
                           M = I + 1
                           GO TO 625
                        END IF
  620                CONTINUE
  625                CONTINUE
C                    a non-zero was found, slide the exponent down to
C                    fill in the gap left by the truncated zeros.
                     DO 630 I = M,LENGTH
                        IF (L .LE. LENGTH) THEN
                           BUF(I) = BUF(L)
                        ELSE
                           BUFSTR(I:LENGTH) = BLNK
                           GO TO 635
                        END IF
                        L = L + 1
  630                CONTINUE
  635                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
C
C     copy the final string, blanks and all
      IF (JUST .NE. 0) THEN
C        left justified (i.e., JUST != 0)
         J = 1
         DO 710 I = 1,LENGTH
            IF (BUF(J) .NE. BLNK) GO TO 715
            J = J + 1
  710    CONTINUE
  715    CONTINUE
         JLEN = INDEX (BUFSTR(J:LENGTH),BLNK)
         IF (JLEN .EQ. 0) THEN
            JLEN = LENGTH - J + 1
         ELSE
            JLEN = JLEN - 1
         END IF
         K = 1
         DO 720 I = J,LENGTH
            STR(K) = BUF(I)
            K = K + 1
  720    CONTINUE
         DO 730 I = K,LENGTH
            STR(I) = BLNK
  730    CONTINUE
      ELSE
C        right justified (i.e., JUST == 0)
         J = LENGTH
         DO 810 I = LENGTH,1,-1
            IF (BUF(J) .NE. BLNK) GO TO 815
            J = J - 1
  810    CONTINUE
  815    CONTINUE
         DO 820 I = 1,LENGTH-J
            STR(I) = BLNK
  820    CONTINUE
         K = 1
         DO 830 I = LENGTH-J+1,LENGTH
            STR(I) = BUF(K)
            K = K + 1
  830    CONTINUE
C        with right justified strings, JLEN is always LENGTH
         JLEN = LENGTH
      END IF
C
      RETURN
C
C      expensive internal writes were replaced, but this is what they did
C  95  FORMAT('(1PE',I2,'.',I2,'E',I1,')')
C  96  FORMAT('(F',I2,'.',I2,')')
C
      END
C
C
C
      SUBROUTINE   DPRCHR
     I                    (DPRIN, LENGTH,
     M                     JUST,
     O                     JLEN, STR)
C
C
C     + + + PURPOSE + + +
C     This routine converts a double precision number to a
C     character string.  The number is right justified in the
C     string if the flag JUST is zero or if the number requires
C     an exponent, otherwise it is left justified.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER      LENGTH, JUST, JLEN
      DOUBLE PRECISION  DPRIN
      CHARACTER*1  STR(LENGTH)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DPRIN  - double precision value to be converted to a character string
C     LENGTH - available length for output character string
C     JUST   - output justification
C              0 - right justified
C              1 - left justified
C              will be forced to 0 if an exponent is required
C     JLEN   - actual length of output character string
C     STR    - output character string
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
      INCLUDE 'const.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER      I0, I1, I2, I, J, K, L, M, PREC, EXPO, WHDIGS, 
     $             EXDIGS, FDIGS, NOCNT, KLEN
      DOUBLE PRECISION  R1, R2, R3, ARTMP, RSUB, MINFIX, MAXFIX, X
      CHARACTER*1  FMTBUF(12), BUF(79),  ZERO,  BLNK,  POINT,  STAR
      CHARACTER*12 FMT
      CHARACTER*79 BUFSTR
      LOGICAL      FLOAT, FRAC, NEG, KILL, NOFIT
C
C     + + + LOCAL DEFINITIONS + + +
C     NOCNT  - for values less than 1.0, NOCNT is the number of
C              zeros immediately following the decimal point (which
C              "don't count" in terms of the number of significant
C              digits representable by the machine); for values
C              greater than or equal to 1.0, NOCNT = 0
C
C     + + + EQUIVALENCES + + +
      EQUIVALENCE (BUF,BUFSTR)
      EQUIVALENCE (FMT,FMTBUF)
C
C     + + + FUNCTIONS + + +
      INTEGER      DWDIGS
      DOUBLE PRECISION  FPART
      LOGICAL      NONZER, NZFRAC
C
C     + + + INTRINSICS + + +
      INTRINSIC    IABS, DABS, DLOG10, DBLE, LEN, INDEX, 
     $             IDINT, DINT, DNINT, IDNINT
C
C     + + + EXTERNALS + + +
      EXTERNAL     INTCHR, NUMINI, DWDIGS
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  I0, I1, I2,  ZERO, BLNK, POINT, STAR
     .    /  0,  1,  2,   '0',  ' ',   '.',  '*' /
C
C     + + + STATEMENT FUNCTION DEFINITIONS + + +
C     absolute value of the FRACtional PART (of a real number)
      FPART(X)  = DABS(X) - DABS(DINT(X))
C     NON-ZERo real number? - true or false  N.B. X should not be < 0.0
      NONZER(X) = X .GT. 0.0
C     Non-Zero FRACtional part of a real number? - true or false
      NZFRAC(X) = NONZER(FPART(X))
C     number of Whole DIGitS - for X > 0
Cmyg  WDIGS(X)  = IDINT(DLOG10(X*DP1MIN)) + 1
C
C     + + + END SPECIFICATIONS + + +
C
C     may need to init machine-dependent numeric constants (const.inc)
      CALL NUMINI
C
C     save time with the common case of DPRIN .eq. 0
      IF (DABS(DPRIN) .LE. D0MIN) THEN
         IF (LENGTH .GE. 3) THEN
            BUFSTR = '0.0'
         ELSE IF (LENGTH .EQ. 2) THEN
            BUFSTR = '0.'
         ELSE IF (LENGTH .EQ. 1) THEN
            BUFSTR = '0'
         ELSE
            NOFIT = .TRUE.
         END IF
      ELSE
C
C        the number of decimal digits of precision offered can be found
C        in the variable DPREC of the ICONST common block.
         PREC = DPREC
C
C        is the number negative?  set NEG and define MAXFIX/MINFIX
         IF (DPRIN .LT. 0.0) THEN
            NEG = .TRUE.
            MAXFIX = DBLE(10.0)**(LENGTH-1)
            MINFIX = DBLE(1.0/10.0)**(LENGTH-1)
         ELSE
            NEG = .FALSE.
            MAXFIX = DBLE(10.0)**LENGTH
            MINFIX = DBLE(1.0/10.0)**LENGTH
         END IF
C
C        this copy of the absolute value of the number is used frequently
         ARTMP = DABS(DPRIN)
C
C        using scientific notation, how many digits will be in the exponent?
C        the answer will be in EXDIGS.
         R1 = DLOG10(ARTMP*DP1MIN)
         EXPO = IDINT(R1)
         IF (R1 .LT. 0.0) THEN
            IF (NZFRAC(R1)) THEN
               EXPO = EXPO - 1
            END IF
         END IF
         IF (EXPO .EQ. 0) THEN
            EXDIGS = 1
         ELSE
            EXDIGS = IDINT(DLOG10(DBLE(IABS(EXPO))*DP1MIN)) + 1
         END IF
C
C        how many digits in the whole part of the number?
         IF (ARTMP .GE. 1.0) THEN
            WHDIGS = DWDIGS(ARTMP)
         ELSE
C           one digit to allow room for 0
            WHDIGS = 1
         END IF
C
         IF (ARTMP.LT.MINFIX .OR. ARTMP.GT.MAXFIX
     .      .OR. WHDIGS.GT.PREC) THEN
C           use scientific notation
            FLOAT = .FALSE.
C           force right justification with scientific notation
            JUST = 0
         ELSE
C           use floating point notation
            FLOAT  = .TRUE.
C           does the number have a non-zero fractional part?
            FRAC   = NZFRAC(DPRIN)
C           here, in the context of a floating point number, EXDIGS is
C           a count of EXtra whole DIGits (not digits in the exponent).
            EXDIGS = 0
            NOCNT  = 0
            IF (FRAC) THEN
C              if the fractional part were rounded, would the number of
C              of whole digits increase?  (EXtra whole DIGitS)
               IF (DNINT(FPART(DPRIN)) .GT. 0.0) THEN
C                  IF ((ARTMP+DBLE(1.0)) .GE. 1.0) THEN
                     IF (DWDIGS(ARTMP+DBLE(1.0)) .GT. WHDIGS) EXDIGS = 1
C                  END IF
               END IF
               IF (ARTMP .LT. 1.0) THEN
C                 since there is a non-zero fractional part (FRAC = TRUE),
C                 and the absolute value of the number is less than 1.0,
C                 how many consecutive zeros immediately follow the decimal
C                 point?  The NOCNT (no count) zeros don't count against the
C                 precision available.
                  R1 = DABS(DLOG10(ARTMP*DP1MIN))
                  IF (NZFRAC(R1)) THEN
                     NOCNT = IDINT (R1)
                  ELSE
                     NOCNT = IDINT (R1) - 1
                  END IF
               END IF
            END IF
         END IF
C
         IF (FLOAT) THEN
C           using floating point notation
            RSUB = DPRIN
C
C           first, assume it's not negative, taking into account the '.':
            FDIGS = LENGTH - (WHDIGS + 1)
            IF (FDIGS-NOCNT .GT. PREC) FDIGS = PREC+NOCNT
C           if it is negative, there will be less room for fractional digits
            IF (NEG) FDIGS = FDIGS - 1
C           if the number of WHole digits is one, it might just be a zero
C           in which case, for purposes of precision, we can consider the
C           number of whole digits to be zero.
            IF (WHDIGS .EQ. 1) THEN
C              if the whole number IS a zero, then maybe it would be better
C              to add an extra digit of precision to the fraction rather than
C              display the zero whole number.  However, don't do this if
C              the precision would be exceeded.
               IF (DINT(ARTMP) .LE. 0.0 .AND. FDIGS.LT.PREC+NOCNT) THEN
                  WHDIGS = 0
C                 we could just add that extra digit of precision to the
C                 fraction, but if it's just zero too, it looks better to
C                 keep the zero to the left of the decimal.
                  IF (FRAC) THEN
C                    r1 gets the number that we had planned to display, but
C                    raised to a power of 10 such that it is a whole number.
                     WRITE(99,*) 'ARTMP =',ARTMP
                     WRITE(99,*) 'LENGTH=',LENGTH
                     WRITE(99,*) 'FDIGS =',FDIGS 
                     WRITE(99,*) 'DBLE(10.0)**FDIGS =',DBLE(10.0)**FDIGS
                     WRITE(99,*) 'ARTMP*DBLE(10.0)**FDIGS =',
     $                            ARTMP*DBLE(10.0)**FDIGS
                     WRITE(99,*) 'DNINT(ARTMP*DBLE(10.0)**FDIGS) =',
     $                            DNINT(ARTMP*DBLE(10.0)**FDIGS)
                     WRITE(99,*) '--'
                     WRITE(99,*) ' '
                     R1 = DNINT(ARTMP*DBLE(10.0)**FDIGS)
C                    r2 gets a fraction representing digits which we had
C                    not planned to display and r3 is that fraction times 10.
                     R2 = (ARTMP*DBLE(10.0)**FDIGS) - R1
                     R3 = R2*10
C                    now, if 1) the number we were not going to display is,
C                    when rounded, non-zero, or if 2) the number passed in
C                    is negative, but everything we had planned on displaying
C                    was zero, then we add the extra digit of precision.
C                    in the first case, we just end up dropping the zero to
C                    the left of the decimal and adding an extra digit of
C                    precision; in the second case, the extra digit of
C                    precision is added only if the digits that were to be
C                    displayed previously were all zeros and the number
C                    itself is negative, so if the extra digit is zero, it
C                    is displayed to make up for the fact that the negative
C                    sign (for which room has been given) won't be displayed,
C                    but if the extra digit is non-zero, the negative sign
C                    will be displayed and the zero before the decimal will
C                    be lost.
                     IF (IDNINT(R3).NE.0 .OR. 
     .                  (NEG .AND. R1.LE.1.0D-20)) THEN
                           FDIGS  = FDIGS + 1
                     END IF
                  END IF
C                 if nocnt, the number of zero digits immediately
C                 following the decimal point (which don't count against the
C                 number of digits of precision representable by the machine),
C                 is greater than zero (this can only be the case if the
C                 absolute value of the number is less than one, as here)
C                 then we must ensure that the number of digits displayed
C                 does not exceed the actual machine precision
               END IF
            END IF
C
            IF ((WHDIGS + FDIGS - NOCNT) .GT. PREC) THEN
               FDIGS = PREC - WHDIGS + NOCNT
            END IF
C
            NOFIT = .FALSE.
            FMT = '(F  .  )'
            IF (FDIGS .GT. 0) THEN
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH,FDIGS
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE IF (FDIGS .EQ. 0) THEN
               RSUB = DNINT (RSUB)
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH,FDIGS
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE IF (FDIGS .EQ. -1) THEN
               RSUB = DNINT (RSUB)
               FDIGS = 0
C               expensive internal write replaced, but this is what it did
C               WRITE(FMT,96) LENGTH+1,FDIGS
               I = LENGTH + 1
               CALL INTCHR (I,I2,I0,KLEN,FMTBUF(3))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(6))
            ELSE
               NOFIT = .TRUE.
            END IF
C
         ELSE
C           using scientific notation
            RSUB  = DPRIN
            NOFIT = .FALSE.
            IF (NEG) THEN
               IF (EXDIGS+5 .LE. LENGTH) THEN
                  FDIGS = LENGTH-(EXDIGS+5)
                  IF (FDIGS+1 .GT. PREC) FDIGS = PREC - 1
               ELSE
                  NOFIT = .TRUE.
               END IF
            ELSE
               IF (EXDIGS+4 .LE. LENGTH) THEN
                  FDIGS = LENGTH-(EXDIGS+4)
                  IF (FDIGS+1 .GT. PREC) FDIGS = PREC - 1
               ELSE
                  NOFIT = .TRUE.
               END IF
            END IF
C            expensive internal write replaced, but this is what it did
C            IF (.NOT. NOFIT) WRITE(FMT,95) LENGTH,FDIGS,EXDIGS
            IF (.NOT. NOFIT) THEN
               FMT = '(1PE  .  E )'
               CALL INTCHR (LENGTH,I2,I0,KLEN,FMTBUF(5))
               CALL INTCHR (FDIGS,I2,I0,KLEN,FMTBUF(8))
               CALL INTCHR (EXDIGS,I1,I0,KLEN,FMTBUF(11))
            END IF
         END IF
C
C        here we either put asterisks or use 'write' to convert the number
         IF (NOFIT) THEN
            JLEN = 0
            DO 400 I = 1,LENGTH
               BUF(I) = STAR
  400       CONTINUE
         ELSE
C           some compilers don't like blanks embedded in the format string
C           as they are now, so first squeeze it together, and then use it
C           to format the given number.
            I = INDEX(FMT,BLNK)
            IF (I .GT. 0) THEN
               J = I
               L = LEN(FMT)
               DO 420 K = I,L
                  IF (FMTBUF(K) .NE. BLNK) THEN
                     FMTBUF(J) = FMTBUF(K)
                     J = J + 1
                  END IF
  420          CONTINUE
               DO 430 K = J,L
                  FMTBUF(K) = BLNK
  430          CONTINUE
            END IF
C
            I = INDEX(FMT,BLNK)
            IF (I .EQ. 0) I = LEN(FMT)
C
            WRITE(BUFSTR,FMT(1:I)) RSUB
C
         END IF
C
C        in either form, at most 1 trailing zero should be left.
C        make J point to the '.' if there is one
         J = INDEX (BUFSTR,POINT)
         IF (FLOAT) THEN
            IF (J .NE. 0) THEN
C              kludge to change " .0" to "0.0" in some cases on some 'chines
               IF ((J-1) .GT. 0) THEN
                  IF (BUF(J-1) .EQ. BLNK) THEN
                     BUF(J-1) = ZERO
                  END IF
               END IF
C              we don't want to truncate any zeros if there's no '.'
C              make K point to the last zero (if there is one)
               I = 0
               K = 0
  510          CONTINUE
               I = INDEX (BUFSTR(K+1:79),ZERO)
               IF (I .NE. 0) THEN
                  K = K + I
                  GO TO 510
               END IF
               KILL = .TRUE.
               IF (K .NE. 79) THEN
C                 only kill zeros that are not significant.  if the last
C                 zero is followed by something other than a blank,
C                 then you can't get rid of it.
                  IF (BUF(K+1) .NE. BLNK) KILL = .FALSE.
               END IF
               IF (K .GT. J+1 .AND. KILL) THEN
C                 only truncate zeros if they're to the right of the decimal
C                 and don't get rid of a zero that is immediately to the
C                 right of the decimal point.
                  DO 520 I = K,J+2,-1
                     IF (BUF(I) .EQ. ZERO) THEN
                        BUF(I) = BLNK
                     ELSE
C                       once a non-zero is found, get out of the loop
                        GO TO 525
                     END IF
  520             CONTINUE
  525             CONTINUE
               END IF
            END IF
         ELSE
C           get rid of trailing zeros in scientific notation
            IF (J .NE. 0) THEN
C              we don't won't to truncate any zeros if there's no '.'
C              make L point to the 'E'
               L = INDEX (BUFSTR,'E')
               IF (L .NE. 0) THEN
C                 make K point to the last digit before the 'E'
                  K = L - 1
                  IF (K .GT. J+1) THEN
C                    only truncate zeros between '.' and 'E', and don't
C                    get rid of the zero (if there is one) immediately to the
C                    right of the decimal.
                     M = J+2
                     DO 620 I = K,J+2,-1
                        IF (BUF(I) .EQ. ZERO) THEN
C                          don't truncate the last trailing zero
                           BUF(I) = BLNK
                        ELSE
                           M = I + 1
                           GO TO 625
                        END IF
  620                CONTINUE
  625                CONTINUE
C                    a non-zero was found, slide the exponent down to
C                    fill in the gap left by the truncated zeros.
                     DO 630 I = M,LENGTH
                        IF (L .LE. LENGTH) THEN
                           BUF(I) = BUF(L)
                        ELSE
                           BUFSTR(I:LENGTH) = BLNK
                           GO TO 635
                        END IF
                        L = L + 1
  630                CONTINUE
  635                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
C
C     copy the final string, blanks and all
      IF (JUST .NE. 0) THEN
C        left justified (i.e., JUST != 0)
         J = 1
         DO 710 I = 1,LENGTH
            IF (BUF(J) .NE. BLNK) GO TO 715
            J = J + 1
  710    CONTINUE
  715    CONTINUE
         JLEN = INDEX (BUFSTR(J:LENGTH),BLNK)
         IF (JLEN .EQ. 0) THEN
            JLEN = LENGTH - J + 1
         ELSE
            JLEN = JLEN - 1
         END IF
         K = 1
         DO 720 I = J,LENGTH
            STR(K) = BUF(I)
            K = K + 1
  720    CONTINUE
         DO 730 I = K,LENGTH
            STR(I) = BLNK
  730    CONTINUE
      ELSE
C        right justified (i.e., JUST == 0)
         J = LENGTH
         DO 810 I = LENGTH,1,-1
            IF (BUF(J) .NE. BLNK) GO TO 815
            J = J - 1
  810    CONTINUE
  815    CONTINUE
         DO 820 I = 1,LENGTH-J
            STR(I) = BLNK
  820    CONTINUE
         K = 1
         DO 830 I = LENGTH-J+1,LENGTH
            STR(I) = BUF(K)
            K = K + 1
  830    CONTINUE
C        with right justified strings, JLEN is always LENGTH
         JLEN = LENGTH
      END IF
C
      RETURN
C
C      expensive internal writes were replaced, but this is what they did
C  95  FORMAT('(1PE',I2,'.',I2,'E',I1,')')
C  96  FORMAT('(F',I2,'.',I2,')')
C
      END
C
C
C
      INTEGER   FUNCTION   RWDIGS
     I                           (RVAL)
C
C     + + + PURPOSE + + +
C     Determines number of whole digits in input argument.  Used
C     for real values greater than zero.
C
C     + + + DUMMY ARGUMENTS + + +
      REAL         RVAL
C
C     + + + ARGUMENT DEFINITIONS + + +
C     RVAL   - real value
C
C     + + + LOCAL VARIABLES + + +
      INTEGER      LOGVAL
C
C     + + + INTRINSICS + + +
      INTRINSIC    INT, ALOG10
C
C     + + + END SPECIFICATIONS + + +
C
      LOGVAL = INT(ALOG10(RVAL))
      IF (.NOT. (RVAL.GE.10.**LOGVAL .AND. RVAL.LT.10.**(LOGVAL+1)))
     $  LOGVAL = LOGVAL + 1
C
      RWDIGS = LOGVAL + 1
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   DWDIGS
     I                           (DVAL)
C
C     + + + PURPOSE + + +
C     Determines number of whole digits in input argument.  Used
C     for double precision values greater than zero.
C
C     + + + DUMMY ARGUMENTS + + +
      DOUBLE PRECISION  DVAL
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DVAL   - double precision value
C
C     + + + LOCAL VARIABLES + + +
      INTEGER      LOGVAL
C
C     + + + INTRINSICS + + +
      INTRINSIC    IDINT, DLOG10
C
C     + + + END SPECIFICATIONS + + +
C
      LOGVAL = IDINT(DLOG10(DVAL))
      IF (.NOT. (DVAL.GE.10.D0**LOGVAL .AND. DVAL.LT.10.D0**(LOGVAL+1)))
     $  LOGVAL = LOGVAL + 1
C
      DWDIGS = LOGVAL + 1
C
      RETURN
      END
C
C
C
      SUBROUTINE   DECCHX
     I                    (REAIN,LEN,SIGDIG,DECPLA,
     O                     STR)
C
C     + + + PURPOSE + + +
C     Right justifies the real number REAIN into the
C     character array STR of size LEN.  The number will have
C     SIGDIG significant digits and DECPLA decimal places.
C     If the number will not fit into STR as specified, it
C     will be output using an exponent.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,SIGDIG,DECPLA
      REAL        REAIN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     REAIN  - real value to be converted to a character array
C     LEN    - available size for output character array
C     SIGDIG - significant digits for output
C     DECPLA - number of decimal places for output
C               0 - no decimal places
C              <0 - force exponential output
C     STR    - output character array
C
C     + + + COMMON BLOCKS + + +
C
C     + + + LOCAL VARIABLES + + +
      INTEGER      I,J,K,L,JUST,TSDIG,DPTFG,LDZRO,ITMP,MCRY,FORCE,
     1             LDECPL,EXPFLG,FRSTD,L20,L1
      REAL         RWRIT
      CHARACTER*20 UBBUF
      CHARACTER*9  UFMTL
      CHARACTER*1  UFMT(9),USBUF(20),C1
C
C     + + + EQUIVALENCES + + +
      EQUIVALENCE (UBBUF,USBUF),(UFMTL,UFMT)
C
C     + + + FUNCTIONS + + +
      INTEGER      CHRDIG
      CHARACTER*1  DIGCHR
C
C     + + + INTRINSICS + + +
      INTRINSIC   ABS
C
C     + + + EXTERNALS + + +
      EXTERNAL   CHRCHR, CHRDIG, DIGCHR, INTCHR, CHRDEL, CHRINS
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  L1,L20/1,20/,  C1/'1'/
C
C     + + + END SPECIFICATIONS + + +
C
      TSDIG= SIGDIG
      IF (TSDIG.EQ.0) TSDIG= 5
C
      IF (DECPLA.LT.0) THEN
C       force exponential instead of zero
        FORCE = 1
        LDECPL= -DECPLA
      ELSE
C       dont force exponential
        FORCE = 0
        LDECPL= DECPLA
      END IF
      JUST= 0
C
      UFMT(1)= '('
      UFMT(2)= ' '
      UFMT(3)= ' '
      UFMT(4)= 'F'
      I= 2
      CALL INTCHR (LEN,I,JUST,J,UFMT(5))
      UFMT(7)= '.'
      UFMT(8)= DIGCHR(LDECPL)
      UFMT(9)= ')'
C
      WRITE (UBBUF,UFMTL) REAIN
      IF (CHRDIG(USBUF(1)).LT.0.AND.USBUF(1).NE.' '.AND.
     1    USBUF(1).NE.'.'     .AND.USBUF(1).NE.'-') THEN
C       real number didn't fit in user specified format, try E
        EXPFLG = 1
      ELSE IF (FORCE.EQ.1) THEN
C       check to see if value written is zero
        READ (UBBUF,UFMTL) RWRIT
Chnb is following condition appropriate (for extremely large magnitude numbers
Chnb that might have a large absolute difference?)
        IF ((ABS(RWRIT).LT.1.0E-10).OR.ABS(RWRIT-REAIN).GT.1.E-6)
     1    EXPFLG= 1
      ELSE
C       no exponent needed here
        EXPFLG = 0
      END IF
      IF (EXPFLG.EQ.1) THEN
C       try exponential format
        UFMT(2)= '1'
        UFMT(3)= 'P'
        UFMT(4)= 'E'
        I= LEN- 6
        IF (REAIN.LT.0) I= I- 1
        IF (TSDIG-1.LT.I) THEN
C         don't want too many digits in exp output
          I= TSDIG- 1
        END IF
        UFMT(8)= DIGCHR(I)
        WRITE (UBBUF,UFMTL) REAIN
      ELSE IF (TSDIG.GT.0) THEN
C       it fit, remove insignificant digits, if any
        I= 0
        J= 0
        DPTFG= 0
        LDZRO= 1
        FRSTD= 0
 10     CONTINUE
          I= I+ 1
C         have we passed the decimal point
          IF (USBUF(I).EQ.'.') THEN
            DPTFG= I
          ELSE
C           are we on a digit?
            ITMP= CHRDIG(USBUF(I))
            IF (ITMP.GT.0.OR.(ITMP.EQ.0.AND.LDZRO.EQ.0)) THEN
C             set counter for first 0-9 digit
              IF (FRSTD .EQ. 0) FRSTD= I
              LDZRO= 0
C             J is counter for significant digits
              J= J+ 1
              IF (J.GT.TSDIG) THEN
C               we have enough significant digits
                IF (ITMP.GE.5.AND.J.EQ.TSDIG+1) THEN
C                 we need to carry from the first insig digit
                  K= I- 1
C                 K is next digit back
 20               CONTINUE
                    IF (K.EQ.DPTFG) K= K-1
                    L= CHRDIG(USBUF(K))+ 1
                    IF (L.EQ.10) THEN
                      IF (K .EQ. FRSTD) THEN
C                       need to shift over since 9 rounded to 10
                        CALL CHRINS (L20,K,C1,USBUF)
                        MCRY = 0
                        L = 0
                        IF (USBUF(1) .EQ. ' ') THEN
C                         shift back if 1st char blank
                          CALL CHRDEL (L20, L1, USBUF)
                          FRSTD = FRSTD - 1
                        ELSE
C                         can't shift so reset pointers
                          I = I + 1
                          K = K + 1
                        END IF
                      ELSE
                        MCRY= 1
                        L= 0
                      END IF
                    ELSE
                      MCRY= 0
                    END IF
                    USBUF(K)= DIGCHR(L)
                    K= K- 1
                  IF (MCRY.EQ.1) GO TO 20
                END IF
C               now get rid of insig digits
                IF (DPTFG.EQ.0) THEN
C                 before the decimal point
                  USBUF(I)= '0'
                ELSE
C                 after the decimal point
                  USBUF(I)= ' '
                END IF
              END IF
            END IF
          END IF
        IF (I.LT.LEN) GO TO 10
      END IF
C
C     fill in output buffer
      CALL CHRCHR (LEN,USBUF,STR)
C
      RETURN
      END
C
C
C
      CHARACTER*1 FUNCTION   DIGCHR
     I                             (DIG)
C
C     Convert a single digit to a character.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER   DIG
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DIG    - digit to be converted to a character
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I
      CHARACTER*1 TDIG(9),TZERO
C
C     + + + DATA INITIALIZATIONS + + +
      DATA TDIG  /'1','2','3','4','5','6','7','8','9'/
      DATA TZERO /'0'/
C
C     + + + END SPECIFICATIONS + + +
C
      I = 1
      DIGCHR = TZERO
  10  CONTINUE
        IF (I.EQ.DIG) DIGCHR = TDIG(I)
        I = I + 1
      IF (I.LT.10.AND.DIGCHR.EQ.TZERO) GO TO 10
C
      RETURN
      END
C
C
C
      SUBROUTINE   INTCHR
     I                    (INTIN,LENA,JUST,
     O                     JLEN,STRNG)
C
C     + + + PURPOSE + + +
C     Convert the integer number INTIN to a character array.
C     The number will be right justified in the array if the
C     flag JUST is zero, otherwise is will be left justified.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LENA,INTIN,JLEN,JUST
      CHARACTER*1 STRNG(LENA)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     INTIN  - integer value to be converted to a character array
C     LENA   - available size for output character array
C     JUST   - output justification
C              0 - right justified in the field
C              1 - left justified in the field
C     JLEN   - actual number of characters output to character array
C     STRNG  - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,IM,IST,NUMCHR, LEN
      INTEGER*4   JTMP1,JTMP2,PTEN,CHKSIZ,REMTMP,INTTMP
      CHARACTER*1 BLNK,ZERO,MINUS,FILCHR,STR(9)
C
C     + + + FUNCTIONS + + +
      CHARACTER*1 DIGCHR
C
C     + + + INTRINSICS + + +
      INTRINSIC   ALOG10, INT, MOD, REAL
C
C     + + + EXTERNALS + + +
      EXTERNAL    DIGCHR, ZIPC, COPYC
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  MINUS, BLNK, ZERO, FILCHR
     &     /  '-',  ' ',  '0',    '*' /
C
C     + + + END SPECIFICATIONS + + +
C
      INTTMP = INTIN
      LEN  = LENA
      IF (LEN.GT.9) LEN = 9
      CALL ZIPC (LEN,BLNK,STR)
      IF (INTTMP.EQ.0) THEN
C       process zero
        IF (JUST.EQ.0) THEN
          STR(LEN) = ZERO
          JLEN = LEN
        ELSE
          STR(1) = ZERO
          JLEN = 1
        END IF
      ELSE
        IST = 1
        IF (INTTMP.LT.0) THEN
          IST   = 2
          INTTMP= -INTTMP
          STR(1)= MINUS
        END IF
Chnb  guess what, the integral portion of the log base 10 of a number
Chnb  like 9,999,999 is different than that for 9,999,999*1.00001
Chnb  (therefore, the following code won't work!)
        NUMCHR = INT (ALOG10(REAL(INTTMP)*1.00001))
        IF (JUST.EQ.0) THEN
          JLEN = LEN
        ELSE
          JLEN = NUMCHR + IST
          IF (JLEN.GT.LEN) JLEN = LEN
        END IF
C                 **** ADDED BECAUSE OF HP BUG IN SSB #5838 ***
        JTMP1 = 10
        JTMP2 = (JLEN - IST + 1)
C       IF (JTMP2.GT.4) WRITE (*,'("INTCHR,JTMP2:",I8)') JTMP2
        PTEN = JTMP1** JTMP2
        CHKSIZ = INTTMP- PTEN
        IF (CHKSIZ.GE.0) THEN
C         resulting string will be too long- fill with stars
          CALL ZIPC (JLEN,FILCHR,STR)
        ELSE
Chnb  Enough is enough.  I hadn't said anything to this point, but
Chnb  filling the character array with the most significant digit
Chnb  first is just too ridiculous.  Change this to
Chnb  "DO 130 I = JLEN,IST,-1" or something like that.
          DO 130 I = IST, JLEN
            PTEN = PTEN/ 10
            REMTMP = MOD(INTTMP,PTEN)
            IM = (INTTMP-REMTMP)/PTEN
            STR(I) = DIGCHR(IM)
            IM = I- 1
            IF (IM.GT.0) THEN
              IF (STR(I).EQ.ZERO) THEN
                IF (STR(IM).EQ.BLNK.OR.STR(IM).EQ.MINUS) THEN
                  STR(I) = STR(IM)
                  STR(IM)= BLNK
                END IF
              END IF
            ELSE
              IF (STR(1).EQ.ZERO) STR(1) = BLNK
            END IF
            INTTMP = REMTMP
 130      CONTINUE
        END IF
      END IF
C
      CALL ZIPC ( LENA, BLNK, STRNG )
      IF (LEN .EQ. LENA) THEN
C       available field length within max allowed length
        CALL COPYC ( LEN, STR, STRNG )
      ELSE IF (JUST .NE. 0) THEN
C       available field length bigger than max, left justify
        CALL COPYC ( LEN, STR, STRNG )
      ELSE
C       available field length bigger than max, right justify
        I = LENA - LEN + 1
        CALL COPYC (LEN, STR, STRNG(I) )
      END IF
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   LENSTR
     I                           (LEN,STR)
C
C     Return the actual length of the character array,
C     excluding trailing blanks.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     STR    - character array
C
C     + + + LOCAL VARIALBES + + +
      INTEGER     LENT,DONE
C
C     + + + END SPECIFICATIONS + + +
C
      DONE = 0
      LENT = LEN
  10  CONTINUE
        IF (STR(LENT).EQ.' ') THEN
          LENT = LENT- 1
        ELSE
          DONE = 1
        END IF
      IF (LENT.GT.0.AND.DONE.EQ.0) GO TO 10
C
      LENSTR= LENT
C
      RETURN
      END
C
C
C
      SUBROUTINE   LFTSTR
     I                    (LEN,
     M                     TITLE)
C
C     + + + PURPOSE + + +
C     Left justify characters in the array TITLE.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 TITLE(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array, 1 <= LEN <= 132
C     TITLE  - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     L,IS,I,K,TLEN
      CHARACTER*1 BUFF(132),BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA BLNK/' '/
C
C     + + + END SPECIFICATIONS + + +
C
      TLEN = LEN
      IF (TLEN.GT.132) TLEN = 132
      I = 0
 10   CONTINUE
        I = I + 1
      IF (TITLE(I).EQ.BLNK.AND.I.LT.TLEN) GO TO 10
      IF (TITLE(I).EQ.BLNK.AND.I.EQ.TLEN) I= I+ 1
      IS = I
C     found beginning of non-blanks
C
      IF (IS.LE.TLEN .AND. IS.NE.1) THEN
C       title not all blanks and not currently left justified
        L = TLEN - (IS-1)
        DO 30 I = 1,TLEN
          BUFF(I) = TITLE(I)
          TITLE(I)= BLNK
 30     CONTINUE
        DO 40 I = 1,L
          K = IS + I - 1
          TITLE(I) = BUFF(K)
 40     CONTINUE
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   PRTLIN
     I                    (DATE,NUMDSN,DATA,WDTH,SGFD,DPLA,THRSH,
     O                     OLEN,TBUFF)
C
C     + + + PURPOSE + + +
C     Convert DATE and an array of real numbers into a character array.
C
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     NUMDSN,DATE(6),WDTH,OLEN,SGFD,DPLA
      REAL        DATA(NUMDSN), THRSH(2)
      CHARACTER*1 TBUFF(250)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DATE   - date
C     NUMDSN - number of data values to output ( 1 <= NUMDSN <= 30 )
C     DATA   - array of NUMDSN data values to be output
C     WDTH   - output width ( <= 250 )
C     SGFD   - significant digits for output
C     DPLA   - number of decimal places for output
C     THRSH  - limits for output
C              (1) - minimum value
C              (2) - maximum value
C     OLEN   - actual number of characters output to TBUFF
C     TBUFF  - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,IPOS,ERRFLG,JUST,J,LEN,ID
      CHARACTER*1 BLNK, STAR
C
C     + + + EXTERNALS + + +
      EXTERNAL   DATLST, DECCHR, DECCHX
C
C     + + + DATA INITIALIZATIONS + + +
      DATA BLNK/' '/,  STAR/'*'/
C
C     + + + END SPECIFICATIONS + + +
C
      DO 10 I = 1,WDTH
        TBUFF(I) = BLNK
 10   CONTINUE
      ID = 23
C     ID is position date end and data starts in ID+1
      JUST = 0
      IPOS = 2
      CALL DATLST (DATE,TBUFF(IPOS),OLEN,ERRFLG)
C
      IF (DATE(3).LT.10) THEN
C       shift date string if day  < 10
        DO 12 I = 1,11
          J = ID - I
          TBUFF(J) = TBUFF(J-1)
 12     CONTINUE
        TBUFF(11) = BLNK
      END IF
C
      IPOS = ID
      LEN = (WDTH-22)/NUMDSN
      IF (LEN.GT.12) LEN = 12
      DO 20 I = 1,NUMDSN
        IF (DATA(I).LT.THRSH(1).OR.DATA(I).GT.THRSH(2)) THEN
C         DO 16 J = 2,LEN
C           TBUFF(IPOS-2+J) = BLNK
C16       CONTINUE
          TBUFF(IPOS-2+LEN) = STAR
        ELSE
          IF (DPLA .LT. 0) THEN
            CALL DECCHR (DATA(I),LEN,JUST,OLEN,TBUFF(IPOS))
          ELSE
            CALL DECCHX (DATA(I),LEN,SGFD,DPLA,TBUFF(IPOS))
          END IF
        END IF
        IPOS = IPOS + LEN
 20   CONTINUE
      OLEN = IPOS - 1
C
      RETURN
      END
C
C
C
      SUBROUTINE   PRTLNO
     I                    (DATE,NUMDSN,DATA,WDTH,SGFD,DPLA,DTFG,
     O                     OLEN,TBUFF)
C
C     + + + PURPOSE + + +
C     Convert DATE and an array of real numbers into a character array.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     NUMDSN,DATE(6),WDTH,OLEN,SGFD,DPLA,DTFG(NUMDSN)
      REAL        DATA(NUMDSN)
      CHARACTER*1 TBUFF(250)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     DATE   - date
C     NUMDSN - number of data values to output ( 1 <= NUMDSN <= 30 )
C     DATA   - array of NUMDSN data values to be output
C     WDTH   - output width ( <= 250 )
C     SGFD   - significant digits for output
C     DPLA   - number of decimal places for output
C     DTFG   - array of indicator flag to include data value
C              0 - leave field blank
C              1 - convert data to character
C     OLEN   - actual number of characters output to TBUFF
C     TBUFF  - output character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,IPOS,ERRFLG,JUST,J,LEN,ID
      CHARACTER*1 BLNK
C
C     + + + EXTERNALS + + +
      EXTERNAL   DATLST, DECCHR, DECCHX, ZIPC
C
C     + + + DATA INITIALIZATIONS + + +
      DATA  BLNK
     #    /  ' '/
C
C     + + + END SPECIFICATIONS + + +
C
      CALL ZIPC ( WDTH, BLNK, TBUFF )
      ID = 23
C     ID is position date end and data starts in ID+1
      JUST = 0
      IPOS = 2
      CALL DATLST (DATE,TBUFF(IPOS),OLEN,ERRFLG)
C
      IF (DATE(3).LT.10) THEN
C       shift date string if day  < 10
        DO 12 I = 1,11
          J = ID - I
          TBUFF(J) = TBUFF(J-1)
 12     CONTINUE
        TBUFF(11) = BLNK
      END IF
C
      IPOS = ID
      LEN = (WDTH-22)/NUMDSN
      IF (LEN.GT.12) LEN = 12
      DO 20 I = 1,NUMDSN
        IF (DTFG(I) .EQ. 0) THEN
          TBUFF(IPOS-2+LEN) = BLNK
        ELSE
          IF (DPLA .LT. 0) THEN
            CALL DECCHR (DATA(I),LEN,JUST,OLEN,TBUFF(IPOS))
          ELSE
            CALL DECCHX (DATA(I),LEN,SGFD,DPLA,TBUFF(IPOS))
          END IF
        END IF
        IPOS = IPOS + LEN
 20   CONTINUE
      OLEN = IPOS - 1
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   STRFND
     I                          (LEN,STR,FLEN,FSTR)
C
C     Return the position in the array STR of size LEN that
C     the array FSTR of size FLEN occurs.  If FSTR is not
C     found, a zero is returned.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN,FLEN
      CHARACTER*1 STR(LEN),FSTR(FLEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array being searched
C     STR    - character array to be searched
C     FLEN   - size of character array to search for
C     FSTR   - character array to be searched for
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J,FNDPOS
C
C     + + + END SPECIFICATIONS + + +
C
      FNDPOS= 0
      IF (FLEN.LE.LEN) THEN
        I= 0
        J= 0
 10     CONTINUE
          J= 0
 20       CONTINUE
            I= I+ 1
            J= J+ 1
            IF (J.EQ.FLEN.AND.STR(I).EQ.FSTR(J)) FNDPOS= I- FLEN+ 1
          IF (STR(I).EQ.FSTR(J).AND.FNDPOS.EQ.0.AND.J.LT.FLEN) GO TO 20
          I= I- J+ 1
        IF (I.LT.LEN-FLEN+1.AND.FNDPOS.EQ.0) GO TO 10
      END IF
C
      STRFND= FNDPOS
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   STRLNX
     I                           (NPTS,BUFF)
C
C     Return the number of characters in the array BUFF, including
C     imbedded blanks and excluding leading and trailing blanks.
C     A value of 1 is returned for all blanks.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     NPTS
      CHARACTER*1 BUFF(NPTS)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     NPTS   - size of the character array
C     BUFF   - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     K,KE,KB
      CHARACTER*1 BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA BLNK/' '/
C
C     + + + END SPECIFICATIONS + + +
C
      K = 1
 5    CONTINUE
        IF (BUFF(K).NE.BLNK) GO TO 6
        K = K + 1
      IF (K.LE.NPTS) GO TO 5
 6    CONTINUE
      KB = K -1
C
      K = NPTS
 7    CONTINUE
        IF (BUFF(K).NE.BLNK) GO TO 8
        K = K - 1
      IF (K.GE.1) GO TO 7
 8    CONTINUE
      KE = K
C
      K= KE- KB
      IF (K.LE.0) K=1
      STRLNX = K
C
      RETURN
      END
C
C
C
      SUBROUTINE   ZIPC
     I                  (LEN, ZIP,
     O                   X)
C
C     Fill the character array X of size LEN with
C     the given value ZIP.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 ZIP,X(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array
C     ZIP    - character to fill array
C     X      - character array to be filled
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     L
C
C     + + + END SPECIFICATIONS + + +
C
      DO 100 L= 1, LEN
        X(L)= ZIP
 100  CONTINUE
C
      RETURN
      END
C
C
C
      SUBROUTINE   ZLJUST
     M                   (STRING)
C
C     + + + PURPOSE + + +
C     Remove leading blanks from a character variable.
C
C     + + + DUMMY ARGUMENTS + + +
      CHARACTER STRING*(*)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     STRING - character variable to left jusfify
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J,K,L
C
C     + + + INTRINSICS + + +
      INTRINSIC   LEN
C
C     + + + END SPECIFICATIONS + + +
C
      IF (STRING(1:1) .EQ. ' ') THEN
C       has at least 1 leading blank
        L = LEN(STRING)
        I = 0
 10     CONTINUE
C         loop to look for other leading blanks
          I= I+ 1
        IF (I.LT.L .AND. STRING(I:I).EQ.' ') GO TO 10
C       remove leading blanks
Chnb  some compilers (OTG) complain about "STRING= STRING(I:L)", so ...
        K = 1
        DO 15, J=I,L
           STRING(K:K) = STRING(J:J)
           K = K + 1
 15     CONTINUE
        STRING(K:) = ' '
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   PRTSTR
     I                    (FUNIT,LEN,STR)
C
C     + + + PURPOSE + + +
C     Write a character array to the given file unit.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     FUNIT,LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     FUNIT  - Fortran unit number for output
C     LEN    - size of character array
C     STR    - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,J
C
C     + + + FUNCTIONS + + +
      INTEGER     LENSTR
C
C     + + + EXTERNALS + + +
      EXTERNAL   LENSTR
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT (250A1)
C
C     + + + END SPECIFICATIONS + + +
C
      IF (LEN.GT.0) THEN
C       output string, then cr/lf
        J = LENSTR( LEN, STR )
        WRITE (FUNIT,2000) (STR(I),I=1,J)
      ELSE
C       only write a cr/lf
        WRITE (FUNIT,2000)
      END IF
C
      RETURN
      END
C
C
C
      INTEGER FUNCTION   ZLNTXT
     I                          (STRING)
C
C     + + + PURPOSE + + +
C     Determine length of text in a character variable,
C     i.e., the index of the last non-blank or non-null character.
C
C     + + + DUMMY ARGUMENTS + + +
      CHARACTER STRING*(*)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     STRING - character variable
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,DONFG
      CHARACTER*1 NULL,CTMP
C
C     + + + INTRINSICS + + +
      INTRINSIC   LEN, CHAR
C
C     + + + END SPECIFICATIONS + + +
C
      NULL = CHAR(0)
      I    = LEN(STRING)
      DONFG= 0
      IF (I.GT.0) THEN
C       string is not all blanks
 10     CONTINUE
          CTMP= STRING(I:I)
          IF (CTMP.EQ.' ' .OR. CTMP.EQ.NULL) THEN
C           still nothing useful
            I= I- 1
          ELSE
C           a character
            DONFG= 1
          END IF
        IF (I.GT.0 .AND. DONFG.EQ.0) GOTO 10
      END IF
C
      ZLNTXT= I
C
      RETURN
      END
C
C
C
      SUBROUTINE   ZTRIM
     M                  (STRING)
C
C     + + + PURPOSE + + +
C     Remove embeded blanks in a character variable
C
C     + + + DUMMY ARGUMENTS + + +
      CHARACTER STRING*(*)
C
C      + + + ARGUMENT DEFINITIONS + + +
C     STRING - character variable having blanks removed
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J
      CHARACTER TEMP*255
C
C     + + + INTRINSICS + + +
      INTRINSIC   LEN
C
C     + + + END SPECIFICATIONS + + +
C
      J = 0
      DO 100 I = 1, LEN(STRING)
C       look at each char
        IF (STRING(I:I) .NE. ' ') THEN
C         not blank, save it
          J = J + 1
          TEMP(J:J) = STRING(I:I)
        END IF
 100  CONTINUE
C
      IF (J .GT. 0) THEN
C       not all blank, return string with no blanks
        STRING = TEMP(1:J)
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   QUPCAS
     I                    (LEN,
     M                     STRING)
C
C     + + + PURPOSE + + +
C     To convert a character string from lower case to upper case
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STRING(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - length of character string
C     STRING - character string to be made upper case
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,ICH
C
C     + + + INTRINSICS + + +
      INTRINSIC  ICHAR, MOD, CHAR
C
C     + + + END SPECIFICATIONS + + +
C
      DO 10 I = 1, LEN
        ICH= ICHAR(STRING(I))
        ICH= MOD(ICH,128)
        IF (ICH.GE.97 .AND. ICH.LE.122) THEN
C         character is lower case
          STRING(I)= CHAR(ICH-32)
        END IF
 10   CONTINUE
C
      RETURN
      END
C
C
C
      INTEGER   FUNCTION   CKNBLV
     I                           (LEN,CBUF)
C
C     + + + PURPOSE + + +
C     Check character array CBUF for all blanks.  Return
C     a zero if all blanks, otherwise return position in
C     character array of first non-blank character.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 CBUF(LEN)
C
C     + + + ARGUMENT DEFINITION + + +
C     LEN    - size of character array
C     CBUF   - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,J
C
C     + + + END SPECIFICATIONS + + +
C
      I = 0
      J = 0
 10   CONTINUE
        I = I+ 1
        IF (CBUF(I) .NE. ' ') J = I
      IF (I.LT.LEN .AND. J.EQ.0) GO TO 10
C
      CKNBLV = J
C
      RETURN
      END
C
C
C
      SUBROUTINE   RHTSTR
     I                    (LEN,
     M                     TITLE)
C
C     + + + PURPOSE + + +
C     Right justify characters in the array TITLE.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 TITLE(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - size of character array, 1 <= LEN <= 132
C     TITLE  - character array
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     IS,I,TLEN,I1,I2
      CHARACTER*1 BLNK
C
C     + + + DATA INITIALIZATIONS + + +
      DATA BLNK/' '/
C
C     + + + END SPECIFICATIONS + + +
C
C     find number of blanks on the right
      TLEN = LEN
      IF (TLEN.GT.132) TLEN = 132
      I = TLEN + 1
 10   CONTINUE
        I = I - 1
      IF (TITLE(I).EQ.BLNK.AND.I.GT.1) GO TO 10
      IS = I
C     found end of non-blanks
C
      IF (IS.LT.TLEN) THEN
C       title not currently right justified
        DO 30 I = 1,IS
          I1 = TLEN - I + 1
          I2 = IS - I + 1
          TITLE(I1) = TITLE(I2)
 30     CONTINUE
        DO 40 I = 1,TLEN-IS
          TITLE(I) = BLNK
 40     CONTINUE
      END IF
C
      RETURN
      END   
C
C
C
      SUBROUTINE   ADCOMA
     I                   (LEN,
     M                    STR)
C
C     + + + PURPOSE + + +
C     This routine places a comma(s) in the real number in the string
C     every 3 digits.  String may include sign, decimal point, and
C     decimal digits.  If there is not enough room in the string, the
C     string is returned as it was entered.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     LEN
      CHARACTER*1 STR(LEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     LEN    - length of the string
C     STR    - character string of a decimal number
C
C     + + + PARAMETERS + + + 
      INTEGER   MAXTMP
      PARAMETER (MAXTMP=50)
C 
C     + + + LOCAL VARIABLES + + + 
      INTEGER   LOC,I1,NEG,SHFT,OLEN,I,IDIG,IOLD,INEW,JUST
      CHARACTER*1 TEMP(MAXTMP),DOT,MINUS,BLNK
C
C     + + + FUNCTIONS + + + 
      INTEGER  LENSTR, STRFND
C
C     + + + EXTERNAL + + + 
      EXTERNAL  LENSTR, LFTSTR, RHTSTR, STRFND, ZIPC, COPYC
C
C     + + + DATA INITIALIZATIONS + + + 
      DATA MINUS/'-'/,  DOT/'.'/,  BLNK/' '/, I1/1/
C
C     + + + END SPECIFICATIONS + + + 
C
C     check if right of left justified
      IF (STR(LEN) .EQ. ' ') THEN
C       assume string was left justified
        JUST = 0
      ELSE
        JUST = 1
      END IF
C     shift to left
      CALL LFTSTR (LEN,STR)
C     locate position of decimal point if any
      LOC = STRFND (LEN,STR,I1,DOT)
C     check for minus sign
      IF (STR(1) .EQ. MINUS) THEN               
        NEG = 1
      ELSE
        NEG = 0
      END IF
C     determine length of string
      OLEN = LENSTR (LEN,STR) 
C     reset LOC for cases of no decimal point
      IF (LOC .LE. 0) LOC = OLEN + 1
C     determine number of commas needed, 10000 or greater
      SHFT = (LOC-2-NEG)/3
C     blank out temp buffer
      CALL ZIPC (MAXTMP,BLNK,TEMP)        
C
      IF (OLEN+SHFT .LE. LEN) THEN
C       sufficient room for commas
        IF (OLEN+SHFT .LE. MAXTMP) THEN
C         sufficient room for temp buffer
          IDIG = 0
          DO 10 I = 1,OLEN
C           loop thru the character string, right to left
C           IOLD is position in string without commas
C           INEW is position in string with commas
            IOLD = OLEN - I + 1
            INEW = IOLD + SHFT
            IF (IOLD .GE. LOC) THEN
C             found decimal digit or point, just shift over
              TEMP(INEW) = STR(IOLD)
            ELSE IF (STR(IOLD) .EQ. '-') THEN
C             INEW should be equal to IOLD because SHFT should be 0
              TEMP(INEW) = STR(IOLD)
            ELSE IF (IDIG  .LT. 3) THEN
C             within cluster of 3, not ready to add comma
              TEMP(INEW) = STR(IOLD)
C             count digits
              IDIG = IDIG + 1
            ELSE
C             must be time to add a comma, IDIG = 3
              TEMP(INEW) = ','
              TEMP(INEW-1) = STR(IOLD)
              IDIG = 1
              SHFT = SHFT - 1
            END IF
 10       CONTINUE
C
C         replace with new string
          CALL COPYC (LEN,TEMP,STR)
          IF (JUST .EQ. 1 .AND. LEN .GT. SHFT+OLEN) THEN
C           was right justified and blank spaces remain
C           so right justify
            CALL RHTSTR (LEN,STR)
          END IF
        END IF
      END IF
C
      RETURN
      END                   
