forked from JackS9/phatpsy
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathbomb.f
220 lines (218 loc) · 8.22 KB
/
bomb.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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
SUBROUTINE BOMB(IERROR)
IMPLICIT REAL*8(A-H,O,P,R-Z),LOGICAL*1(Q)
C-----------------------------------------------------------------------
C
C BOMB...
C
C THIS ROUTINE HANDLES ALL THE ERROR MESSAGES AND EXITS FOR THE
C PROGRAM. EACH CALL (ONE, IN GENERAL) PRODUCES A DUMP OF VARIOUS
C VARIABLES WHICH MAY AID IN DEBUGGING, THE ADDRESSES OF THE
C DYNAMICALLY ALLOCATED ARRAYS, AND A SUBROUTINE TRACEBACK.
C
C ENTRY: WARN...
C
C THIS ENTRY PRODUCES A WARNING MESSAGE, RESETS A LOGICAL
C VARIABLE AND RETURNS.
C
C QRESET... RESET VALUE OF LOGICAL VARIABLE.
C
C ENTRY: SETBOM...
C
C THIS ENTRY RESETS THE ENTRIES IN THE ERROR OPTION TABLE AS
C DEFAULTED BY FORTRAN COMPILER. (CALL TO ERRSET).
C
C ENTRY: DUMP...
C
C THIS ENTRY DOES NOT PRODUCE A MESSAGE BUT DOES PRODUCE THE
C USUAL DUMPS AND TRACEBACK FOLLOWED BY A NORMAL RETURN.
C
C NRTNS.... =0 --> NO ARRAY MAP OR TRACEBACK PRODUCED.
C =N --> ARRAY MAPS FOR ROUTINES 1-N AND TRACEBACK
C ARE PRODUCED.
C
C ROUTINES CALLED: ERRSET, ERRTRA, ARRMAP
C
C COMMON USAGE:
C
C /PARMS/ USES - APARM(*),IPARM(*),QPARM(*)
C
C /IODATA/ USES - IUNIT(*),LENBUF
C
C /DYNAMC/ USES - NROUT
C
C /FIXED/ USES - MXCORE,NWCORE,NWORDS
C
C-----------------------------------------------------------------------
COMMON /PARMS/ APARM(20),IPARM(50),QPARM(50)
EQUIVALENCE (IPARM(1),NATOM), (IPARM(2),NELEM),
X (IPARM(3),NUCZ), (IPARM(4),IEQAT),
X (IPARM(5),MSTO), (IPARM(6),NORB),
X (IPARM(7),IORBT), (IPARM(8),NORBT),
X (IPARM(9),N2ORBT), (IPARM(10),IATOM),
X (IPARM(11),IDIFAT), (IPARM(12),MXMSTO),
X (IPARM(13),N2ATOM), (IPARM(14),MXNORB),
X (IPARM(15),MXNSTO), (IPARM(16),MDIFAT),
X (IPARM(17),NMAX), (IPARM(18),NNMX),
X (IPARM(19),NNMXM1), (IPARM(20),LMAX)
EQUIVALENCE (IPARM(21),LMXP1), (IPARM(22),LLMXP1),
X (IPARM(23),LLMXP2), (IPARM(24),NCGC),
X (IPARM(25),MXITER), (IPARM(26),IELEM),
X (IPARM(27),M2STO), (IPARM(28),L3MX),
X (IPARM(29),NFACT), (IPARM(30),NABDIM),
X (IPARM(31),NVTERM), (IPARM(32),NSTO),
X (IPARM(33),ISPIN), (IPARM(34),NYLM),
X (IPARM(35),N2ORB), (IPARM(36),LAST),
X (IPARM(37),MXCYCL), (IPARM(38),NCYCL),
X (IPARM(39),IUNIT0), (IPARM(40),M4STO)
EQUIVALENCE (QPARM(1),QRSTRT), (QPARM(2),QBAKUP),
X (QPARM(3),QNWBAS), (QPARM(4),QOPEN),
X (QPARM(5),QFIRST), (QPARM(6),QLAST),
X (QPARM(7),QDEBUG), (QPARM(8),QSEPAT),
X (QPARM(9),QCMPTD), (QPARM(10),QEWMO),
X (QPARM(11),QFIXED), (QPARM(12),QVIRTL),
X (QPARM(13),QNWVEC), (QPARM(14),QMOVE),
X (QPARM(15),QFLIP),
X (QPARM(19),QGSTAT), (QPARM(20),QPLOT),
X (QPARM(21),QCORE), (QPARM(22),QPRINT),
X (QPARM(23),QAUDMP), (QPARM(24),QATOM)
EQUIVALENCE (APARM(1),EXPMIN), (APARM(2),CONVRG),
X (APARM(3),THETA), (APARM(4),CDAMP),
X (APARM(5),CACCEL), (APARM(6),RANGE),
X (APARM(7),PKSCAL), (APARM(8),PKE),
X (APARM(9),ALPHA), (APARM(10),BETA)
COMMON /IODATA/ IUNIT(20),LENBUF
EQUIVALENCE (IUNIT(6),IW)
NAMELIST /VDUMP/ NATOM,NELEM,NUCZ,IEQAT,MSTO,NORB,IORBT,NORBT,
X N2ORBT,IATOM,IDIFAT,MXMSTO,N2ATOM,MXNORB,MXNSTO,
X MDIFAT,NMAX,NNMX,NNMXM1,LMAX,LMXP1,LLMXP1,LLMXP2,
X NCGC,MXITER,IELEM,M2STO,L3MX,NFACT,NABDIM,NVTERM,
X NSTO,ISPIN,NYLM,N2ORB,MXCYCL,NCYCL,IUNIT0,M4STO,
X QRSTRT,QBAKUP,QNWBAS,QOPEN,QFIRST,QLAST,QDEBUG,
X QSEPAT,QCMPTD,QEWMO,QFIXED,QVIRTL,QNWVEC,QMOVE,
X QFLIP,QGSTAT,QPLOT,QCORE,EXPMIN,CONVRG,THETA,
X CDAMP,CACCEL,RANGE,PKSCAL,TIMEND,QPRINT,QAUDMP,
X QATOM,MXCORE,NWCORE,NWORDS,LAST
CHARACTER*8 ROUTIN
COMMON /DYNAMC/ LISTAR(500),IPTR(10),NNIA(10),NID(10),NXARG(10),
X ROUTIN(10),NROUT
COMMON /FIXED/ MXCORE,NWCORE,NWORDS
CHARACTER*8 EXCEED(6)
DATA EXCEED/' HAS EXC','EEDED TH','E PREVIO','USLY SPE',
X 'CIFIED M','AXIMUM ('/
NRTNS=NROUT
QRTRN=.FALSE.
WRITE (IW,1000)
GO TO 5
C
C...
ENTRY WARN(IERROR,QRESET)
NRTNS=0
QRTRN=.TRUE.
5 CONTINUE
IF (IERROR.LT.1 .OR. IERROR.GT.18) GO TO 190
GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170,
X 180),IERROR
10 WRITE (IW,2000) IERROR,EXCEED
GO TO 190
20 WRITE (IW,3000) IERROR,EXCEED
GO TO 190
30 WRITE (IW,4000) IERROR,EXCEED
GO TO 190
40 WRITE (IW,5000)
GO TO 190
50 WRITE (IW,6000) IERROR,EXCEED
GO TO 190
60 WRITE (IW,7000) IERROR
QRESET=.TRUE.
RETURN
70 WRITE (IW,8000) IERROR,EXCEED
GO TO 190
80 WRITE (IW,9000) IERROR,EXCEED
GO TO 190
90 WRITE (IW,10000) IERROR,EXCEED
GO TO 190
100 WRITE (IW,11000) IERROR
GO TO 190
110 WRITE (IW,12000) IERROR
GO TO 190
120 WRITE (IW,13000) IERROR
QRESET=.FALSE.
RETURN
130 WRITE (IW,14000) IERROR
GO TO 190
140 WRITE (IW,15000)
QDEBUG=.TRUE.
QPRINT=.TRUE.
MXITER=1
MXCYCL=NCYCL+1
QRTRN=.TRUE.
GO TO 190
150 WRITE (IW,16000) IERROR
RETURN
160 WRITE (IW,17000) IERROR,NORB
GO TO 190
170 WRITE (IW,18000) IERROR
GO TO 190
180 WRITE (IW,19000) IERROR
QRESET=.TRUE.
RETURN
C
C...
ENTRY DUMP(NRT)
NRTNS = NRT
QRTRN=.TRUE.
WRITE (IW,1000)
190 CONTINUE
WRITE (IW,20000)
WRITE (IW,VDUMP)
IF (NRTNS.EQ.0) GO TO 210
DO 200 NR=1,NRTNS
CALL ARRMAP(NR)
200 CONTINUE
C CALL ERRTRA
210 CONTINUE
WRITE (IW,21000)
IF (QRTRN) RETURN
STOP
C
C...
ENTRY SETBOM
C CALL ERRSET (207,1,1,2)
C CALL ERRSET (208,256,-1,1)
C CALL ERRSET (209,1,1,2,0,225)
C CALL ERRSET (231,1,1,2,0,239)
C CALL ERRSET (241,1,1,2,0,301)
RETURN
1000 FORMAT('1','...................................................')
2000 FORMAT('-*** ERROR',I3,' - AN N-QUANTUM NUMBER',
X 6A8,'NMAX) ***')
3000 FORMAT('-*** ERROR',I3,' - AN L-QUANTUM NUMBER',
X 6A8,'LMAX) ***')
4000 FORMAT('-*** ERROR',I3,' - THE NO. OF STO''S (W/ ML''S) (JSTO)',
X 6A8,'MSTO) ***')
5000 FORMAT('-*** SYMMETRY OPERATION NOT IMPLEMENTED YET ***')
6000 FORMAT('-*** ERROR',I3,' - THE NO. OF STO''S (W/ ML''S) (MSTO)',
X 6A8,'MXMSTO) ***')
7000 FORMAT('-*** WARNING',I3,' - NEW VECTORS AND SYMMETRY MUST BE',
X ' READ IN SINCE THIS IS NOT A RESTART ***')
8000 FORMAT('-*** ERROR',I3,' - THE NUMBER OF ELEMENTS (IELEM)',
X 6A8,'NELEM) ***')
9000 FORMAT('-*** ERROR',I3,' - THE NUMBER OF ATOMS (IATOM)',
X 6A8,'NATOM) ***')
10000 FORMAT('-*** ERROR',I3,' - THE NUMBER OF ATOMIC ORBITALS (IORBT)',
X 6A8,'NORBT) ***')
11000 FORMAT('-*** ERROR',I3,' - AN ML-VALUE HAS EXCEEDED ITS RANGE.')
12000 FORMAT('-*** ERROR',I3,' - ''ISTO'' WAS OUT OF RANGE ***')
13000 FORMAT('-*** WARNING',I3,' - THE NEW VECTORS AND SYMMETRY WILL',
X ' BE IGNORED FOR A BACK-UP ***')
14000 FORMAT('-*** ERROR',I3,' - MODEL POTENTIAL CAN''T BE FIT ***')
15000 FORMAT('-*** SCF DIVERGING - TERMINATION FOLLOWS NEXT CYCLE ***')
16000 FORMAT('-*** WARNING',I3,' - FAILURE TO DETERMINE EIGENVALUE ***')
17000 FORMAT('-*** ERROR',I3,' - FAILURE TO DETERMINE AT LEAST',I3,
X ' EIGENVALUES ***')
18000 FORMAT('-*** ERROR',I3,' - FAILURE TO DETERMINE EIGENVECTOR ***')
19000 FORMAT('-*** WARNING',I3,' - ENCOUNTERED DIFFICULTY IN MODEL',
X ' POTENTIAL FIT - RESETTING ***')
20000 FORMAT('-DUMP OF GLOBAL VARIABLES, PARM(*)...'/)
21000 FORMAT('-','...................................................')
END