Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/bnk5.ban
There are 3 other files named bnk5.ban in the archive. Click here to see a list.
C *** BANK ***
C
C SUBROUTINE TO OUTPUT BANK DATA TO A USER SPECIFIED DEVICE UNDER A
C USER SPECIFIED FORMAT. OUTPUT TO LPT: IS SPOOLED AND PRINTED WITH
C THE PRINTS ROUTINE.
C
SUBROUTINE OUTPUT
DIMENSION ID(12500),LV(125),NNS(18,6),IWO(125),YZ(2)
DIMENSION D(12500),SET(240),FET(240),SAV(5),XX(9)
EQUIVALENCE (LV,NNS),(ID,D),(AMISS,MISS),(YZ,FNAMD)
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
COMMON /DEV/ IDLG,ICC,IBNK
COMMON /VAR/ LICVR,NHV,IV(2,20)
COMMON /OBS/ LICOB,NHO,IO(2,20)
COMMON /SEL/ NS,ISEL(5,20),IDATA(20,20)
COMMON /FMT/ LICFMT,FORM(48)
COMMON /OOUT/ LICDEV,DEV,FNAM
DOUBLE PRECISION FNAM,FNAMD,BNKNM,DATCR
DATA MISS/"400000000000/
YZ(1)='LPT.S'
YZ(2)='PL '
XX(1)='A'
XX(2)='I'
XX(3)='F'
XX(4)='G'
XX(5)='E'
XX(6)='('
XX(7)=')'
XX(8)='D'
XX(9)='O'
IOUT=2
ISWOUT=0
IF(DEV.NE.'LPT') GO TO 101
DEV='DSK'
FNAM=FNAMD
ISWOUT=1
101 OPEN(UNIT=IOUT,DEVICE=DEV,ACCESS='SEQOUT',FILE=FNAM)
NUMBRV=0
DO 102 I=1,NHV
102 NUMBRV=NUMBRV+IV(2,I)-IV(1,I)+1
NUMBRV=NUMBRV+NS
IF(NUMBRV.GT.1000) PAUSE 'ERROR'
LND=12500/NUMBRV-2
IF(LND.GT.125) LND=125
JND=LND+2
IBLK=0
M=1
NOBASE=(NO+124)/125
IBASE=NOBASE*NV+1
DO 103 I=1,NHV
C FIND TYPE INFORMATION FIRST
K=IV(1,I)
105 NBLK=(K+5)/6+IBASE
IONE=K-((K-1)/6)*6
IF(NBLK.EQ.IBLK) GO TO 104
READ(IBNK#NBLK) LV
IBLK=NBLK
104 ID((NS+M)*JND)=NNS(10,IONE)
ID((NS+M)*JND-1)=NNS(1,IONE)
M=M+1
K=K+1
IF(K.LE.IV(2,I)) GO TO 105
103 CONTINUE
C
C NOW CHECK FORMAT OR CREATE MY OWN FORMAT. IF CREATE MY OWN
C FIXED ALWAYS I-(I15) FLOATING ALWAYS (G), AND ALPHA
C IS A5
C
IF(LICFMT.NE.0) GO TO 120
C
LINMAX=132
IF(DEV.EQ.'TTY') LINMAX=72
DO 106 I=1,240
106 SET(I)=' '
SET(1)='('
J=2
LIN=0
DO 107 I=NS+1,NUMBRV
MOD=ID((I)*JND)
IF(MOD.NE.0) GO TO 108
SET(J)='G'
LIN=LIN+15
J=J+1
GO TO 110
108 IF(MOD.NE.1) GO TO 109
SET(J)='A'
SET(J+1)='5'
LIN=LIN+5
J=J+2
GO TO 110
109 IF(MOD.NE.2) PAUSE
SET(J)='I'
LIN=LIN+15
J=J+1
110 IF(LIN.LE.LINMAX) GO TO 112
DO 111 K=J,1,-1
IF(SET(K).NE.',') GO TO 111
SET(K)='/'
LIN=5
IF(SET(J-1).EQ.'I') LIN=LIN+10
IF(SET(J-1).EQ.'G') LIN=LIN+10
GO TO 112
111 CONTINUE
PAUSE 'NO COMMA'
112 SET(J)=','
J=J+1
IF(J.LE.237) GO TO 107
WRITE(IDLG,113)
113 FORMAT(' NO ROOM - FORMAT PLEASE SPECIFY YOU OWN FORMAT')
GO TO 900
107 CONTINUE
SET(J-1)=')'
ENCODE(240,114,FORM) SET
114 FORMAT(240A1)
DO 115 J=48,1,-1
IF(FORM(J).NE.' ') GO TO 117
115 CONTINUE
117 WRITE(IDLG,116)(FORM(K),K=1,J)
116 FORMAT(' THE MACHINE SUPPLIED FORMAT IS: ',6A5/(1X,12A5))
GO TO 200
C
C
C USER ENTERED FORMAT CHECK MODE AGAINST WHATS BEING TYPED
C
C
120 DECODE(240,114,FORM) SET
DO 121 N=240,1,-1
IF(SET(N).NE.' ') GO TO 122
121 CONTINUE
122 I=0
123 I=I+1
124 IF(I.GT.N) GO TO 130
DO 125 J=1,9
IF(SET(I).EQ.XX(J)) GO TO 123
125 CONTINUE
IF(SET(I).NE.1H') GO TO 161
C TAKE CARE OF LITERALS ENCLOSED IN QUOTES
K=I
162 I=I+1
IF(I.LE.N) GO TO 164
WRITE(IDLG,163)
163 FORMAT(' UNTERMINATED HOLERITH')
GO TO 900
164 IF(SET(I).NE.1H') GO TO 162
M=I-K+1
DO 165 J=I+1,N
165 SET(J-M)=SET(J)
N=N-M
I=K
GO TO 124
C
161 IF((SET(I).LT.'0').OR.(SET(I).GT.'9')) GO TO 128
DO 127 K=1,4
IF((K+I).GT.N) GO TO 128
DO 126 J=1,9
IF(SET(K+I).NE.XX(J)) GO TO 126
IF(J.EQ.7) GO TO 128
GO TO 123
126 CONTINUE
IF((SET(K+I).LT.'0').OR.(SET(K+I).GT.'9')) GO TO 128
127 CONTINUE
C
C GET RID OF CHARACTER
C
128 DO 129 J=I+1,N
129 SET(J-1)=SET(J)
N=N-1
GO TO 124
C
C REMOVE PARANTHESIS
C
130 ISW=0
I=0
M=1
131 I=I+1
IF(I.GT.N) GO TO 146
IF(SET(I).EQ.XX(6)) GO TO 131
IF(SET(I).EQ.XX(7)) GO TO 131
IF((SET(I).GE.'0').AND.(SET(I).LE.'9')) GO TO 132
FET(M)=SET(I)
M=M+1
IF(M.LT.240) GO TO 131
GO TO 148
132 ISW=1
DO 133 K=1,5
133 SAV(K)=' '
J=1
134 SAV(J)=SET(I)
I=I+1
J=J+1
IF((SET(I).GE.'0').AND.(SET(I).LE.'9')) GO TO 134
135 IF(SAV(5).NE.' ') GO TO 137
DO 136 J=4,1,-1
136 SAV(J+1)=SAV(J)
SAV(1)=' '
GO TO 135
137 ENCODE(5,114,WORD) SAV
DECODE(5,138,WORD) LOOP
138 FORMAT(I5)
IF(SET(I).EQ.XX(6)) GO TO 140
DO 139 J=1,LOOP
FET(M)=SET(I)
M=M+1
IF(M.GT.240) GO TO 148
139 CONTINUE
GO TO 131
140 L=I+1
KOUNT=1
141 IF(SET(L).EQ.XX(6)) KOUNT=KOUNT+1
IF(SET(L).EQ.XX(7)) KOUNT=KOUNT-1
IF(KOUNT.EQ.0) GO TO 142
L=L+1
GO TO 141
142 IF((I+1).GT.(L-1)) GO TO 145
DO 144 J=1,LOOP
DO 143 K=I+1,L-1
FET(M)=SET(K)
M=M+1
IF(M.GT.240) GO TO 148
143 CONTINUE
144 CONTINUE
145 I=L
GO TO 131
146 N=M-1
IF(ISW.EQ.0) GO TO 149
DO 147 I=1,N
147 SET(I)=FET(I)
GO TO 130
148 PAUSE 'PROBLEM IN FMT SEE DICK HOUCHARD'
GO TO 900
149 K=1
DO 150 I=NS+1,NUMBRV
ITYP=0
IF(FET(K).EQ.'A') ITYP=1
IF(FET(K).EQ.'O') ITYP=2
IF(FET(K).EQ.'I') ITYP=2
IF(ITYP.EQ.ID((I)*JND)) GO TO 152
TYPO='FLOAT'
IF(ID((I)*JND).EQ.1) TYPO='ALPHA'
IF(ID((I)*JND).EQ.2) TYPO='FIXED'
WRITE(IDLG,151) TYPO,ID((I)*JND-1),FET(K)
151 FORMAT(' THE ',A5,' VARIABLE ',A5,' CANNOT BE WRITTEN WITH AN ',
1A1,' FORMAT')
GO TO 900
152 K=K+1
IF(K.GT.N) K=1
150 CONTINUE
C
C DONE WITH FORMAT
C
200 I=1
201 K=IO(1,I)
IBASE=(K+124)/125
KK=(IBASE-1)*125
N=0
202 IF((N+1).GT.LND) GO TO 204
N=N+1
IWO(N)=K-KK
K=K+1
IF(K.LE.IO(2,I)) GO TO 203
I=I+1
IF(I.GT.NHO) GO TO 205
K=IO(1,I)
203 LBASE=(K+124)/125
IF(LBASE.EQ.IBASE) GO TO 202
204 IO(1,I)=K
205 IF(NS.LT.1) GO TO 208
DO 207 J=1,NS
KK=(J-1)*JND
LBLK=(ISEL(2,J)-1)*NOBASE+IBASE+1
READ(IBNK#LBLK)LV
DO 206 M=1,N
206 ID(KK+M)=LV(IWO(M))
207 CONTINUE
208 L=NS
DO 211 J=1,NHV
K=IV(1,J)
209 LBLK=(K-1)*NOBASE+IBASE+1
READ(IBNK#LBLK) LV
KK=L*JND
DO 210 M=1,N
210 ID(KK+M)=LV(IWO(M))
L=L+1
K=K+1
IF(K.LE.IV(2,J)) GO TO 209
211 CONTINUE
DO 212 J=1,N
212 IWO(J)=1
C
C SELECT PORTION
C
IF(NS.LT.1) GO TO 222
DO 221 K=1,N
J=1
237 LLN=(J-1)*JND+K
IF(ISEL(3,J).NE.1) GO TO 239
DO 238 M=1,ISEL(5,J)
IF(IDATA(J,M).EQ.MISS) GO TO 213
238 CONTINUE
239 IF(ID(LLN).NE.MISS) GO TO 213
GO TO 250
213 GO TO (231,232,233,234,235,236) ISEL(3,J)
231 DO 240 M=1,ISEL(5,J)
IF(ID(LLN).EQ.IDATA(J,M)) GO TO 220
240 CONTINUE
GO TO 250
232 IF(ID(LLN).LT.IDATA(J,1)) GO TO 220
GO TO 250
233 IF(ID(LLN).LE.IDATA(J,1)) GO TO 220
GO TO 250
234 IF(ID(LLN).GT.IDATA(J,1)) GO TO 220
GO TO 250
235 IF(ID(LLN).GE.IDATA(J,1)) GO TO 220
GO TO 250
236 IF(ID(LLN).NE.IDATA(J,1)) GO TO 220
GO TO 250
250 J=J+1
IF(J.GT.NS) GO TO 251
IF(ISEL(1,J).EQ.ISEL(1,J-1)) GO TO 237
251 IWO(K)=0
GO TO 221
220 J=J+1
IF(J.GT.NS) GO TO 221
IF(ISEL(1,J).EQ.ISEL(1,J-1)) GO TO 220
GO TO 237
221 CONTINUE
C
C DO OUTPUT NOW
C
222 DO 223 J=NS+1,NUMBRV
LLN=(J-1)*JND
DO 224 K=1,N
IF(ID(LLN+K).EQ.MISS) IWO(K)=0
224 CONTINUE
223 CONTINUE
NSS=NS-1
DO 225 K=1,N
IF(IWO(K).EQ.0) GO TO 225
WRITE(IOUT,FORM)(D(K+(J-1)*JND),J=NS+1,NUMBRV)
225 CONTINUE
IF(I.LE.NHO) GO TO 201
CALL RELEAS(IOUT)
IF(ISWOUT.EQ.1) CALL PRINTS(FNAM,2,1,1)
GO TO 1000
900 CALL RELEAS (IOUT)
1000 RETURN
END