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