1#if !defined (PRG_DALTON)
2C FILE    : printpkg.F
3C
4C...   Dalton, Release DALTON2013, pdpack/printpkg.F
5C...
6C...   These routines are in the public domain and can be
7C...   used freely in other programs.
8C...
9C
10C  /* Deck output */
11      SUBROUTINE OUTPUT (AMATRX,ROWLOW,ROWHI,COLLOW,COLHI,ROWDIM,COLDIM,
12     *                   NCTL,LUPRI)
13C.......................................................................
14C Revised 15-Dec-1983 by Hans Jorgen Aa. Jensen.
15C         16-Jun-1986 hjaaj ( removed Hollerith )
16C
17C OUTPUT PRINTS A REAL MATRIX IN FORMATTED FORM WITH NUMBERED ROWS
18C AND COLUMNS.  THE INPUT IS AS FOLLOWS;
19C
20C        AMATRX(',').........MATRIX TO BE OUTPUT
21C
22C        ROWLOW..............ROW NUMBER AT WHICH OUTPUT IS TO BEGIN
23C
24C        ROWHI...............ROW NUMBER AT WHICH OUTPUT IS TO END
25C
26C        COLLOW..............COLUMN NUMBER AT WHICH OUTPUT IS TO BEGIN
27C
28C        COLHI...............COLUMN NUMBER AT WHICH OUTPUT IS TO END
29C
30C        ROWDIM..............ROW DIMENSION OF AMATRX(',')
31C
32C        COLDIM..............COLUMN DIMENSION OF AMATRX(',')
33C
34C        NCTL................CARRIAGE CONTROL FLAG; 1 FOR SINGLE SPACE
35C                                                   2 FOR DOUBLE SPACE
36C                                                   3 FOR TRIPLE SPACE
37C                            hjaaj: negative for 132 col width
38C
39C THE PARAMETERS THAT FOLLOW MATRIX ARE ALL OF TYPE INTEGER.  THE
40C PROGRAM IS SET UP TO HANDLE 5 COLUMNS/PAGE WITH A 1P,5D24.15 FORMAT
41C FOR THE COLUMNS.  IF A DIFFERENT NUMBER OF COLUMNS IS REQUIRED,
42C CHANGE FORMATS 1000 AND 2000, AND INITIALIZE KCOL WITH THE NEW NUMBER
43C OF COLUMNS.
44C
45C AUTHOR;  NELSON H.F. BEEBE, QUANTUM THEORY PROJECT, UNIVERSITY OF
46C          FLORIDA, GAINESVILLE
47C REVISED; FEBRUARY 26, 1971
48C
49C.......................................................................
50C
51      IMPLICIT REAL*8 (A-H,O-Z)
52      INTEGER   ROWLOW,ROWHI,COLLOW,COLHI,ROWDIM,COLDIM,BEGIN,KCOL
53      DIMENSION AMATRX(ROWDIM,COLDIM)
54      CHARACTER*1 ASA(3), BLANK, CTL
55      CHARACTER   PFMT*20, COLUMN*8
56      LOGICAL     IS_NAN
57      PARAMETER (ZERO=0.D00, KCOLP=5, KCOLN=8)
58      PARAMETER (FFMIN=1.D-3, FFMAX = 1.D3)
59      DATA COLUMN/'Column  '/, BLANK/' '/, ASA/' ', '0', '-'/
60C
61      IF (ROWHI.LT.ROWLOW) GO TO 3
62      IF (COLHI.LT.COLLOW) GO TO 3
63C
64      AMAX = ZERO
65      N_NAN = 0
66      DO 10 J = COLLOW,COLHI
67         DO 10 I = ROWLOW,ROWHI
68            IF ( IS_NAN(AMATRX(I,J),AMATRX(I,J)) ) THEN
69               N_NAN = N_NAN + 1
70            ELSE
71               AMAX = MAX( AMAX, ABS(AMATRX(I,J)) )
72            END IF
73   10 CONTINUE
74      IF (N_NAN .GT. 0) WRITE (LUPRI,'(/T6,A,I10,A)')
75     &   'WARNING: matrix contains',N_NAN,' NaN.'
76      IF (AMAX .EQ. ZERO) THEN
77         WRITE (LUPRI,'(/T6,A)') 'Zero matrix.'
78         GO TO 3
79      END IF
80      IF (FFMIN .LE. AMAX .AND. AMAX .LE. FFMAX) THEN
81C        use F output format
82         PFMT = '(A1,I7,2X,8F15.8)'
83         thrpri = 0.5D-8
84      ELSE
85C        use 1PD output format
86         PFMT = '(A1,I7,2X,1P,8D15.6)'
87         thrpri = 1.0D-8*AMAX
88      END IF
89C
90      IF (NCTL .LT. 0) THEN
91         KCOL = KCOLN
92      ELSE
93         KCOL = KCOLP
94      END IF
95      MCTL = ABS(NCTL)
96      IF ((MCTL.LE.3).AND.(MCTL.GT.0)) THEN
97         CTL = ASA(MCTL)
98      ELSE
99         CTL = BLANK
100      END IF
101C
102      LAST = MIN(COLHI,COLLOW+KCOL-1)
103      DO 2 BEGIN = COLLOW,COLHI,KCOL
104         WRITE (LUPRI,1000) (COLUMN,I,I = BEGIN,LAST)
105         DO 1 K = ROWLOW,ROWHI
106            DO 4 I = BEGIN,LAST
107               GO TO 5
108               IF (abs(AMATRX(K,I)).gt.thrpri) GO TO 5
109    4       CONTINUE
110         GO TO 1
111    5       WRITE (LUPRI,PFMT) CTL,K,(AMATRX(K,I), I = BEGIN,LAST)
112    1    CONTINUE
113    2 LAST = MIN(LAST+KCOL,COLHI)
114    3 WRITE(LUPRI,'(A)') '    ==== End of matrix output ===='
115      RETURN
116 1000 FORMAT (/10X,8(5X,A6,I4))
117      END
118C === Deck is_nan ===============
119      LOGICAL FUNCTION IS_NAN(XA,XB)
120C
121C     May 2010, Hans Joergen Aa. Jensen
122C     Purpose: IS_NAN(X,X) is true iff X is NAN
123C
124      REAL*8 XA, XB
125      IS_NAN = XA .NE. XB
126      RETURN
127      END
128#endif
129