forked from JackS9/phatpsy
-
Notifications
You must be signed in to change notification settings - Fork 0
/
outvec.f
119 lines (103 loc) · 3.09 KB
/
outvec.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
SUBROUTINE OUTVEC(EVEC,EVAL,NBAS,NVEC,IW)
IMPLICIT REAL*8(A-H,O,P,R-Z),LOGICAL*1(Q)
CHARACTER*1 QCC,QSKIP,QEJECT
C-----------------------------------------------------------------------
C
C OUTVEC...
C
C THIS ROUTINE WRITES OUT EIGENVECTORS AND EIGENVALUES IN COLUMN
C FORM UPTO 10 COLUMNS PER PAGE AND EIGENVALUES HEADING EACH COLUMN.
C
C DEFINITIONS:
C
C EVEC(*,*)... ARRAY OF EIGENVECTORS (COLUMN PACKED).
C EVAL(*)..... EIGENVALUES IN RESPECTIVE ORDER.
C NBAS........ NUMBER OF ELEMENTS IN EACH VECTOR (ORDER OF
C BASIS). FIRST DIMENSION OF EVEC(*,*).
C NVEC........ NUMBER OF VECTORS. DIMENSION OF EVAL(*) AND
C THE SECOND DIMENSION OF EVEC(*,*).
C IW.......... FORTRAN I/O UNIT FOR WRITING.
C
C ENTRY: PUTMAT...
C
C THIS ENTRY POINT OUTPUTS A GENERAL MATRIX IN COLUMN PACKED
C FORM WITHOUT ANY EIGENVALUES.
C
C ROUTINES CALLED: $PAGE($NLINE); MIN0, IABS, DABS
C
C-----------------------------------------------------------------------
DIMENSION EVEC(NBAS,NVEC),EVAL(NVEC),ROW(10)
CHARACTER*8 UNSCOR
DATA ZERO/0.0D0/,TOLER/5.0D-5/,QSKIP/' '/,QEJECT/' '/,
X MAXCOL/6/,LINECT/80/,
X UNSCOR/'________'/
QCC=QSKIP
NEED=NBAS+4
LAST=0
DO 50 IBEGIN=1,NVEC,MAXCOL
LAST=MIN0(LAST+MAXCOL,NVEC)
WRITE (IW,1000) QCC,(I,I=IBEGIN,LAST)
WRITE (IW,2000) (EVAL(I),I=IBEGIN,LAST)
WRITE (IW,3000) (UNSCOR,I=IBEGIN,LAST)
WRITE (IW,4000)
DO 40 J=1,NBAS
NCOL=0
QDELET=.TRUE.
DO 30 I=IBEGIN,LAST
NCOL=NCOL+1
EVECJI=EVEC(J,I)
IF (DABS(EVECJI).LE.TOLER) EVECJI=ZERO
IF (EVECJI.NE.ZERO) QDELET=.FALSE.
ROW(NCOL)=EVECJI
30 CONTINUE
IF (QDELET) GO TO 40
WRITE (IW,4000) J,(ROW(I),I=1,NCOL)
40 CONTINUE
C CALL $NLINE(LINES)
LINES = 0
QCC=QSKIP
IF (NEED.GT.(LINECT-LINES)) QCC=QEJECT
50 CONTINUE
RETURN
1000 FORMAT(/,A1,I9,9I12)
2000 FORMAT(/' ',10F12.4)
3000 FORMAT(' ',10A12)
4000 FORMAT(' ',I2,F10.4,9F12.4)
END
C
C...
SUBROUTINE PUTMAT(EVEC,NBAS,NVEC,IW)
IMPLICIT REAL*8(A-H,O,P,R-Z),LOGICAL*1(Q)
CHARACTER*1 QCC,QSKIP,QEJECT
DIMENSION EVEC(NBAS,NVEC),ROW(10)
DATA ZERO/0.0D0/,TOLER/5.0D-5/,QSKIP/' '/,QEJECT/' '/,
X MAXCOL/6/,LINECT/80/
QCC=QSKIP
NEED=NBAS+4
LAST=0
DO 50 IBEGIN=1,NVEC,MAXCOL
LAST=MIN0(LAST+MAXCOL,NVEC)
WRITE (IW,1000) QCC,(I,I=IBEGIN,LAST)
WRITE (IW,4000)
DO 40 J=1,NBAS
NCOL=0
QDELET=.TRUE.
DO 30 I=IBEGIN,LAST
NCOL=NCOL+1
EVECJI=EVEC(J,I)
IF (DABS(EVECJI).LE.TOLER) EVECJI=ZERO
IF (EVECJI.NE.ZERO) QDELET=.FALSE.
ROW(NCOL)=EVECJI
30 CONTINUE
IF (QDELET) GO TO 40
WRITE (IW,4000) J,(ROW(I),I=1,NCOL)
40 CONTINUE
C CALL $NLINE(LINES)
LINES = 0
QCC=QSKIP
IF (NEED.GT.(LINECT-LINES)) QCC=QEJECT
50 CONTINUE
RETURN
1000 FORMAT(/,A1,I9,9I12)
4000 FORMAT(' ',I2,F10.4,9F12.4)
END