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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
SUBROUTINE FBSF (ZS,ZD)
C
C GIVEN A LOWER TRIANGULAR FACTOR WITH DIAGONAL SUPERIMPOSED, AND
C WRITTEN WITH TRAILING STRING DEFINITION WORDS, FBS WILL PERFORM
C THE FORWARD-BACKWARD SUBSTITUTION NECESSARY TO SOLVE A LINEAR
C SYSTEM OF EQUATIONS.
C
C OPEN CORE IS DEFINED AS FOLLOWS
C
C ZS( 1 ) - FIRST RIGHT HAND VECTOR ON FILE DBB
C (SIZE = NCOL*NWDS)
C NCOL = NUMBER OF COLUMNS (ROWS) IN LOWER
C TRIANGULAR MATRIX
C NWDS = 1, IF MATRICES ARE REAL SINGLE
C = 2, IF MATRICES ARE REAL DOUBLE OR
C COMPLEX SINGLE
C = 4, IF MATRICES ARE COMPLEX DOUBLE
C ZS( NCOL*NWDS+1 ) - NEXT RIGHT HAND VECTOR
C .
C . ( "KN" RIGHT HAND VECTORS WILL BE LOADED INTO
C . MEMORY)
C .
C ZS( BUF1 ) - BUFFER FOR FILE WITH RIGHT HAND VECTORS
C AND FOR SOLUTION VECTORS
C ZS( BUF2 ) - BUFFER FOR FILE WITH TRIANGULAR MATRIX
C
IMPLICIT INTEGER (A-Z)
LOGICAL IDENT
INTEGER SUBNAM(2) ,BLOCK(15),BEGN ,END
REAL ZS(1) ,XS(4) ,YS(4)
DOUBLE PRECISION ZD(1) ,XD ,YD
CHARACTER UFM*23 ,UWM*25 ,UIM*29
COMMON /LOGOUT/ LOUT
COMMON /XMSSG / UFM ,UWM ,UIM
COMMON /FBSX / DBL(7) ,DBU(7) ,DBB(7) ,DBX(7) ,LCORE ,
1 PREC ,SIGN ,SCRX
COMMON /SYSTEM/ SYSBUF ,NOUT ,SKIP(91) ,KSYS94
COMMON /NAMES / RD ,RDREW ,WRT ,WRTREW ,REW ,
1 NOREW ,EOFNRW ,RSP ,RDP ,CSP ,
2 CDP
COMMON /TYPE / PRC(2) ,WORDS(4) ,RLCMPX(4)
COMMON /PACKX / ITYPE1 ,ITYPE2 ,I1 ,J1 ,INCR1
COMMON /UNPAKX/ ITYPE3 ,I2 ,J2 ,INCR2
COMMON /ZNTPKX/ XD(2) ,IX ,EOL
COMMON /ZBLPKX/ YD(2) ,IY
EQUIVALENCE (DBL(2),NL), (DBB(5),TYPEB), (DBX(5),TYPEX),
1 (XD(1),XS(1)), (YD(1),YS(1))
DATA SUBNAM/ 4HFBSF,4H /
DATA BEGN / 4HBEGN/
DATA END / 4HEND /
C
C GENERAL INITIALIZATION
C
BUF2 = LCORE - SYSBUF
BUF1 = BUF2 - SYSBUF
RC = RLCMPX(TYPEB)
TYPEL = DBL(5)
WDS = WORDS(TYPEL)
NWDS = WDS*NL
NBRLOD = DBB(2)
IDENT = .FALSE.
IF (DBB(4) .EQ. 8) IDENT = .TRUE.
IF (IDENT) NBRLOD = NL
SWITCH = 1
IF (TYPEL.EQ.RSP .AND. RC.EQ.2) SWITCH = 2
IF (TYPEL.EQ.RDP .AND. RC.EQ.2) SWITCH = 3
DBL1 = DBL(1)
NNN = BUF1 - 1
NVECS = NNN/NWDS
IF (NVECS .EQ. 0) CALL MESAGE (-8,NWDS-NNN,SUBNAM)
IF (SWITCH .NE. 1) NVECS = NVECS/2
NPASS = (NBRLOD+NVECS-1)/NVECS
SUBNAM(2) = BEGN
CALL CONMSG (SUBNAM,2,0)
40 NPASS = (NBRLOD+NVECS-1)/NVECS
IF ( NPASS .EQ. 1 ) GO TO 50
NEED = NWDS*NBRLOD + 2*SYSBUF
WRITE ( LOUT, 9001 ) NPASS, NEED
9001 FORMAT(I4,' PASSES REQUIRED, OPEN CORE NEEDS TO BE ',I7
&,' TO ELIMINATE THIS')
50 CONTINUE
I2 = 1
J2 = NL
INCR2 = 1
I1 = 1
J1 = NL
INCR1 = 1
ITYPE1 = TYPEL
ITYPE2 = TYPEX
ITYPE3 = SIGN*TYPEL
DBX(2) = 0
DBX(6) = 0
DBX(7) = 0
NNNDBL = NNN/2
NTERMS = RLCMPX(TYPEL)*NL
K1 = 1
OPRD = RDREW
OPWRT = WRTREW
BLOCK(1) = DBL(1)
C
C OPEN LOWER TRIANGULAR FACTOR FILE (DBL1)
C
CALL GOPEN (DBL1,ZS(BUF2),RDREW)
C
C OPEN RIGHT HAND VECTORS FILE (DBB) AND COMPUTE EXTENT OF THIS PASS
C
100 KN = MIN0(K1+NVECS-1,NBRLOD)
LAST = (KN-K1+1)*NWDS
OPCLS = NOREW
IF (KN .EQ. NBRLOD) OPCLS = REW
IF (IDENT) GO TO 280
CALL GOPEN (DBB,ZS(BUF1),OPRD)
GO TO (140,180,230), SWITCH
C
C NORMAL CASE - FILL CORE WITH RIGHT HAND VECTORS
C
140 DO 170 L = 1,LAST,NWDS
CALL UNPACK (*150,DBB,ZS(L))
GO TO 170
150 LN = L + NWDS - 1
DO 160 LL = L,LN
160 ZS(LL) = 0.
170 CONTINUE
GO TO 390
C
C SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP
C
180 LAST = 2*(KN-K1+1)*NWDS
L = 0
DO 190 K = 1,NNNDBL
190 ZD(K) = 0.0D+0
DO 220 K = K1,KN
ICSPSG = CSP*SIGN
CALL INTPK (*210,DBB,0,ICSPSG,0)
200 CALL ZNTPKI
ZS(L+IX ) = XS(1)
ZS(L+IX+NL) = XS(2)
IF (EOL .EQ. 0) GO TO 200
210 L = L + 2*NL
220 CONTINUE
GO TO 390
C
C SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP
C
230 LAST = 2*(KN-K1+1)*NWDS
L = 0
DO 240 K = 1,NNNDBL
240 ZD(K) = 0.0D+0
DO 270 K = K1,KN
ICDPSG = CDP*SIGN
CALL INTPK (*260,DBB,0,ICDPSG,0)
250 CALL ZNTPKI
ZD(L+IX ) = XD(1)
ZD(L+IX+NL) = XD(2)
IF (EOL .EQ. 0) GO TO 250
260 L = L + 2*NL
270 CONTINUE
GO TO 390
C
C SPECIAL CASE - GENERATE IDENTITY MATRIX
C
280 DO 290 K = 1,NNNDBL
290 ZD(K) = 0.0D+0
L = 0
GO TO (300,320,340,360), TYPEL
300 DO 310 K = K1,KN
ZS(L+K) = 1.0
310 L = L + NTERMS
GO TO 400
320 DO 330 K = K1,KN
ZD(L+K) = 1.0D+0
330 L = L + NTERMS
GO TO 400
340 DO 350 K = K1,KN
ZS(L+2*K-1) = 1.0
350 L = L + NTERMS
GO TO 400
360 DO 370 K = K1,KN
ZD(L+2*K-1) = 1.0D+0
370 L = L + NTERMS
GO TO 400
C
C CLOSE RIGHT HAND VECTORS FILE (DBB).
C START FORWARD-BACKWARD SUBSTITUTION ON RIGHT HAND VECTORS NOW IN CORE
C
390 CALL CLOSE (DBB,OPCLS)
400 CALL REWIND (DBL1)
CALL FWDREC (*610,DBL1)
C
J = TYPEL
GO TO (410,420,430,440), J
410 CALL FBS1 (BLOCK,ZS,ZS(LAST),NWDS)
GO TO 500
420 CALL FBS2 (BLOCK,ZS,ZS(LAST),NWDS)
GO TO 500
430 CALL FBS3 (BLOCK,ZS,ZS(LAST),NWDS)
GO TO 500
440 CALL FBS4 (BLOCK,ZS,ZS(LAST),NWDS)
GO TO 500
C
C OPEN AND PACK SOLUTION VECTORS ONTO OUTPUT FILE (DBX)
C
500 CALL GOPEN (DBX,ZS(BUF1),OPWRT)
GO TO (510,530,560), SWITCH
C
C NORMAL CASE - CALL PACK
C
510 DO 520 L = 1,LAST,NWDS
CALL PACK (ZS(L),DBX,DBX)
520 CONTINUE
GO TO 600
C
C SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP, CALL BLDPK
C
530 L = 0
DO 550 K = K1,KN
CALL BLDPK (CSP,TYPEX,DBX,0,0)
DO 540 I = 1,NL
YS(1) = ZS(L+I )
YS(2) = ZS(L+I+NL)
IY = I
CALL ZBLPKI
540 CONTINUE
CALL BLDPKN (DBX,0,DBX)
L = L + 2*NL
550 CONTINUE
GO TO 600
C
C SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP, CALL BLDPK
C
560 L = 0
DO 580 K = K1,KN
CALL BLDPK (CDP,TYPEX,DBX,0,0)
DO 570 I = 1,NL
YD(1) = ZD(L+I )
YD(2) = ZD(L+I+NL)
IY = I
CALL ZBLPKI
570 CONTINUE
CALL BLDPKN (DBX,0,DBX)
L = L + 2*NL
580 CONTINUE
C
C CLOSE OUTPUT FILE, AND TEST FOR MORE PASSES
C
600 CALL CLOSE (DBX,OPCLS)
IF (KN .EQ. NBRLOD) GO TO 620
K1 = KN + 1
OPRD = RD
OPWRT= WRT
GO TO 100
C
C ERROR
C
610 CALL MESAGE (-2,DBL1,SUBNAM)
C
C JOB DONE. CLOSE TRIANGULAR FACTOR FILE.
C
620 CALL CLOSE (DBL1,REW)
SUBNAM(2) = END
CALL CONMSG (SUBNAM,2,0)
RETURN
END
|
