      SUBROUTINE APRNTD(A, NITEMS, IOUT, MCOL, W, D)
C
C  THIS SUBROUTINE PRINTS OUT NITEMS FROM THE DOUBLE PRECISION ARRAY,
C  A, ON OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
C  THE OUTPUT FORMAT IS 1PDW.D.
C  THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
C  W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
C
C  DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
C
C  WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
C
C  THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
C  IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
C  AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
C  BE DIMENSIONED ACCORDINGLY.
C
C  INPUT PARAMETERS -
C
C    A        - THE START OF THE DOUBLE PRECISION ARRAY TO BE PRINTED
C
C    NITEMS   - THE NUMBER OF ITEMS TO BE PRINTED
C
C    IOUT     - THE OUTPUT UNIT FOR PRINTING
C
C    MCOL     - THE NUMBER OF SPACES ACROSS THE LINE
C
C    W        - THE WIDTH OF THE PRINTED VALUE (1PDW.D)
C
C    D        - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PDW.D)
C
C
C  ERROR STATES -
C
C    1 - NITEMS .LE. ZERO
C
C    2 - W .GT. MCOL
C
C    3 - D .LT. ZERO
C
C    4 - W .LT. D+6
C
      INTEGER  NITEMS, IOUT, MCOL, W, D
      DOUBLE PRECISION  A(NITEMS)
C
      INTEGER  MAX0, MIN0, WW, DD, EMIN, EMAX,
     1         EXPENT, I1MACH, ICEIL, IABS, I10WID
C/6S
C     INTEGER  IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR
C     EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
C/7S
      CHARACTER*1  IFMT1(20), IFMT2(18), BLANK, STAR
      CHARACTER*20 IFMT1C
      CHARACTER*18 IFMT2C
      EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
C/
      INTEGER  INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
      LOGICAL  DUP
      DOUBLE PRECISION  LINE(18), LAST(18)
      REAL  LOGETA
C
C/6S
C     DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
C/7S
      DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
C/
C
C  IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
C
C/6S
C     DATA IFMT1( 1) /1H(/,  IFMT2( 1) /1H(/
C     DATA IFMT1( 2) /1H1/,  IFMT2( 2) /1H1/
C     DATA IFMT1( 3) /1HA/,  IFMT2( 3) /1HA/
C     DATA IFMT1( 4) /1H1/,  IFMT2( 4) /1H1/
C     DATA IFMT1( 5) /1H,/,  IFMT2( 5) /1H,/
C     DATA IFMT1( 6) /1H5/,  IFMT2( 6) /1HI/
C     DATA IFMT1( 7) /1HX/,  IFMT2( 7) /1H7/
C     DATA IFMT1( 8) /1H,/,  IFMT2( 8) /1H,/
C     DATA IFMT1( 9) /1H2/,  IFMT2( 9) /1H1/
C     DATA IFMT1(10) /1HA/,  IFMT2(10) /1HP/
C     DATA IFMT1(11) /1H1/,  IFMT2(11) /1H /
C     DATA IFMT1(12) /1H,/,  IFMT2(12) /1HD/
C     DATA IFMT1(13) /1H /,  IFMT2(13) /1H /
C     DATA IFMT1(14) /1H /,  IFMT2(14) /1H /
C     DATA IFMT1(15) /1HX/,  IFMT2(15) /1H./
C     DATA IFMT1(16) /1H,/,  IFMT2(16) /1H /
C     DATA IFMT1(17) /1H2/,  IFMT2(17) /1H /
C     DATA IFMT1(18) /1HA/,  IFMT2(18) /1H)/
C     DATA IFMT1(19) /1H1/
C     DATA IFMT1(20) /1H)/
C/7S
      DATA IFMT1( 1) /'('/,  IFMT2( 1) /'('/
      DATA IFMT1( 2) /'1'/,  IFMT2( 2) /'1'/
      DATA IFMT1( 3) /'A'/,  IFMT2( 3) /'A'/
      DATA IFMT1( 4) /'1'/,  IFMT2( 4) /'1'/
      DATA IFMT1( 5) /','/,  IFMT2( 5) /','/
      DATA IFMT1( 6) /'5'/,  IFMT2( 6) /'I'/
      DATA IFMT1( 7) /'X'/,  IFMT2( 7) /'7'/
      DATA IFMT1( 8) /','/,  IFMT2( 8) /','/
      DATA IFMT1( 9) /'2'/,  IFMT2( 9) /'1'/
      DATA IFMT1(10) /'A'/,  IFMT2(10) /'P'/
      DATA IFMT1(11) /'1'/,  IFMT2(11) /' '/
      DATA IFMT1(12) /','/,  IFMT2(12) /'D'/
      DATA IFMT1(13) /' '/,  IFMT2(13) /' '/
      DATA IFMT1(14) /' '/,  IFMT2(14) /' '/
      DATA IFMT1(15) /'X'/,  IFMT2(15) /'.'/
      DATA IFMT1(16) /','/,  IFMT2(16) /' '/
      DATA IFMT1(17) /'2'/,  IFMT2(17) /' '/
      DATA IFMT1(18) /'A'/,  IFMT2(18) /')'/
      DATA IFMT1(19) /'1'/
      DATA IFMT1(20) /')'/
C/
C
C/6S
C     IF (NITEMS .LE. 0) CALL
C    1  SETERR(27H  APRNTD - NITEMS .LE. ZERO, 27, 1, 2)
C/7S
      IF (NITEMS .LE. 0) CALL
     1  SETERR('  APRNTD - NITEMS .LE. ZERO', 27, 1, 2)
C/
C
C/6S
C     IF (W .GT. MCOL) CALL
C    1  SETERR(22H  APRNTD - W .GT. MCOL, 22, 2, 2)
C/7S
      IF (W .GT. MCOL) CALL
     1  SETERR('  APRNTD - W .GT. MCOL', 22, 2, 2)
C/
C
C/6S
C     IF (D .LT. 0) CALL
C    1  SETERR(22H  APRNTD - D .LT. ZERO, 22, 3, 2)
C/7S
      IF (D .LT. 0) CALL
     1  SETERR('  APRNTD - D .LT. ZERO', 22, 3, 2)
C/
C
C/6S
C     IF (W .LT. D+6) CALL
C    1  SETERR(21H  APRNTD - W .LT. D+6, 21, 4, 2)
C/7S
      IF (W .LT. D+6) CALL
     1  SETERR('  APRNTD - W .LT. D+6', 21, 4, 2)
C/
C
C     EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
C     MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
C
      IF (EXPENT .GT. 0) GO TO 10
         LOGETA = ALOG10(FLOAT(I1MACH(10)))
         EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(15)-1)))
         EMAX = ICEIL(LOGETA*FLOAT(I1MACH(16)))
         EXPENT = I10WID(MAX0(EMIN, EMAX))
C
C     COMPUTE THE FORMATS.
C
   10 WW = MIN0(99, MAX0(W, 5+EXPENT))
      CALL S88FMT(2, WW, IFMT2(13))
      DD = MIN0(D, (WW-(5+EXPENT)))
      CALL S88FMT(2, DD, IFMT2(16))
C
C  NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
C
      NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW))
      CALL S88FMT(1, NCOL, IFMT2(11))
      WW = WW-2
C  THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
      CALL S88FMT(2, WW, IFMT1(13))
C
C  I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
C  J COUNTS THE NUMBER ON A GIVEN LINE,
C  COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
C
      I = 1
      J = 0
      COUNT = 0
C
C  THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
C  IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
C  FULL IS PUT INTO THE ARRAY, LINE.
C  WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
C  THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
C  TO CHECK FOR REPEAT OR DUPLICATED LINES.
C  ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
C  COUNTER, COUNT, IS SET TO ONE.
C  THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
C  GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
C  OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
C  DUPLICATE LINES.
C
C  ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
C  IN A LINE.
C
   20 IF (I .GT. NITEMS)  GO TO 90
        J = J+1
        LINE(J) = A(I)
        IF (J .EQ. 1) ILINE = I
        IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
          IF (COUNT .EQ. 0) GO TO 50
            DUP = .TRUE.
            DO 30 K=1,NCOL
   30         IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
            IF (I .EQ. NITEMS  .AND.  J .LT. NCOL) DUP = .FALSE.
            IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
              IF (.NOT. DUP) GO TO 40
                COUNT = COUNT+1
                IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
     1                                 STAR, STAR, STAR, STAR
                IF (I .EQ. NITEMS)  GO TO 50
                  GO TO 70
   40         WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
   50     WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
          COUNT = 1
          DO 60 K=1,NCOL
   60       LAST(K) = LINE(K)
   70     ILAST = ILINE
          J = 0
   80   I = I+1
        GO TO 20
   90 RETURN
      END
