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
|
SUBROUTINE DFBS
C
C FBS L,U,B/X/V,Y,ISYM=0/V,Y,KSIGN=1/V,Y,IPREC=0/V,Y,ITYPE=0 $
C
C ISYM = 1 USE FBS
C = -1 USE GFBS
C = 0 CHOOSE WHICH BASED ON SUPPLIED INPUT
C KSIGN = 1, SOLVE LUX= B
C -1, LUX=-B
C IPREC = REQUESTED PRECISION - DEFAULT BASED ON INPUT OR SYSTEM(55)
C ITYPE = REQUESTED TYPE OF X - DEFAULT IS LOGICAL CHOICE ON INPUT
C
C REVISED 12/91 BY G.CHAN/UNISYS
C FATAL ERROR IN FBS (NOT GFBS) IF INPUT MATRIX IS NOT A LOWER
C TRIANGULAR FACTOR
C
INTEGER L,U,B,X,SBNM(2),DOSI(3),REFUS(3),OUTPT,SCR
DIMENSION ZZ(1)
CHARACTER UFM*23,UWM*25,UIM*29,SFM*25,SWM*27
COMMON /XMSSG / UFM,UWM,UIM,SFM,SWM
COMMON /BLANK / ISYM, KSIGN, IPREC, ITYPE
COMMON /SYSTEM/ KSYSTM(65)
COMMON /FBSX / IL(7),IU(7),IB(7),IX(7),INX,IP1,IS1,ISCR
COMMON /GFBSX / JL(7),JU(7),JB(7),JX(7),JNX,JP1,JS1
CZZ COMMON /ZZDFB1/ Z(1)
COMMON /ZZZZZZ/ Z(20000)
CZZ COMMON /ZZDFB2/ ZZ(1)
EQUIVALENCE (ZZ(1),Z(1))
EQUIVALENCE (KSYSTM(55),KPREC),(KSYSTM(2),OUTPT)
DATA L, U, B, X, SCR / 101,102,103,201,301 /
DATA SBNM / 4HDFBS,1H /
DATA DOSI / 4HSING, 4HDOUB, 4HMLTP/, REFUS / 2*3H ,3HREF/
C
C
JU(1) = U
CALL RDTRL (JU)
10 IF (ISYM) 150,20,30
20 ISYM = -1
IF (JU(1) .LT. 0) ISYM = 1
GO TO 10
C
C SET UP CALL TO FBS
C
30 NOGO = 0
IL(1) = L
CALL RDTRL (IL)
IF (IL(1) .GT. 0) GO TO 40
CALL MESAGE (30,198,L)
NOGO = 1
40 CONTINUE
IF (IL(4) .NE. 4) GO TO 100
N = IL(2)
IB(1) = B
CALL RDTRL (IB)
IF (NOGO .EQ. 0) GO TO 50
CALL MESAGE (-30,199,SBNM)
50 CONTINUE
INX = KORSZ(Z)
IPREC1= MAX0(IL(5),IB(5),IU(5))
IF (IPREC1 .GT. 2) IPREC1 = IPREC1 - 2
IF (IPREC1.LT.1 .OR. IPREC1.GT.2) IPREC1 = KPREC
IF (IPREC.EQ.IPREC1 .OR. IPREC.EQ.0) GO TO 70
IF (IPREC.LT.1 .OR. IPREC.GT.2) IPREC = 3
WRITE (OUTPT,60) SWM,DOSI(IPREC),REFUS(IPREC),SBNM,DOSI(IPREC1)
60 FORMAT (A27,' 2163, REQUESTED ',A4,'LE PRECISION ',A3,' USED BY ',
1 2A4,2H. ,A4,'LE PRECISION IS LOGICAL CHOICE')
IF (IPREC .NE. 3) IPREC1 = IPREC
70 IPREC = IPREC1
IP1 = IPREC1
IS1 = KSIGN
LTYPE = IPREC1
IF (IL(5).EQ.3 .OR. IL(5).EQ.4 .OR. IU(5).EQ.3 .OR. IU(5).EQ.4 .OR
CWKBR spr 93014 1 .IL(5).EQ.3 .OR. IL(5).EQ.4) LTYPE = IPREC1 + 2
1 .IB(5).EQ.3 .OR. IB(5).EQ.4) LTYPE = IPREC1 + 2
IF (ITYPE.EQ.0 .OR. ITYPE.EQ.LTYPE) GO TO 90
JJ = 1
IF (ITYPE.LT.1 .OR. ITYPE.GT.4) JJ = 3
WRITE (OUTPT,80) SWM,ITYPE,REFUS(JJ),SBNM,LTYPE
80 FORMAT (A27,' 2164, REQUESTED TYPE ',I4,2H, ,A3,' USED BY ',2A4,
1 '. TYPE ',I4,' IS LOGICAL CHOICE.')
IF (JJ .NE. 3) LTYPE = ITYPE
90 ITYPE = LTYPE
IX(5) = ITYPE
IX(1) = X
ISCR = SCR
CALL FBS (Z,Z)
IX(3) = N
IX(4) = 2
IF (IX(3) .EQ. IX(2)) IX(4) = 1
CALL WRTTRL (IX)
GO TO 200
C
100 CALL FNAME (IL(1),IL(2))
WRITE (OUTPT,110) IL(2),IL(3),IL(4)
110 FORMAT ('0*** INPUT MATRIX ',2A4,' TO FBS MODULE IS NOT A LOWER ',
1 'TRIANGULAR FACTOR. FORM =',I4)
CALL ERRTRC ('DFBS ',110)
GO TO 200
C
C SET UP CALL TO GFBS
C
150 JL(1) = L
CALL RDTRL (JL)
N = JL(2)
JB(1) = B
CALL RDTRL (JB)
JNX = KORSZ(ZZ)
IPREC1= MAX0(JL(5),JB(5),JU(5))
IF (IPREC1 .GT. 2) IPREC1 = IPREC1 - 2
IF (IPREC1.LT.1 .OR. IPREC1.GT.2) IPREC1 = KPREC
IF (IPREC.EQ.IPREC1 .OR. IPREC.EQ.0) GO TO 160
IF (IPREC.LT.1 .OR. IPREC.GT.2) IPREC = 3
WRITE (OUTPT,60) SWM,DOSI(IPREC),REFUS(IPREC),SBNM,DOSI(IPREC1)
IF (IPREC .NE. 3) IPREC1 = IPREC
160 IPREC = IPREC1
JP1 = IPREC1
JS1 = KSIGN
JX(1) = X
LTYPE = IPREC1
IF (JL(5).EQ.3 .OR. JL(5).EQ.4 .OR. JU(5).EQ.3 .OR. JU(5).EQ.4 .OR
1 .JL(5).EQ.3 .OR. JL(5).EQ.4) LTYPE = IPREC1 + 2
IF (ITYPE.EQ.0 .OR. ITYPE.EQ.LTYPE) GO TO 170
JJ = 1
IF (ITYPE.LT.1 .OR. ITYPE.GT.4) JJ = 3
WRITE (OUTPT,80) SWM,ITYPE,REFUS(JJ),SBNM,LTYPE
IF (JJ .NE. 3) LTYPE = ITYPE
170 ITYPE = LTYPE
JX(5) = ITYPE
CALL GFBS (ZZ,ZZ)
JX(3) = N
JX(4) = 2
IF (JX(3) .EQ. JX(2)) JX(4) = 1
CALL WRTTRL (JX)
C
200 RETURN
END
|
