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