Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bank/bnk8.d20
There are 3 other files named bnk8.d20 in the archive. Click here to see a list.
C *** BANK ***
C
C SUBROUTINE TO PRINT DATA OR DICTIONARY ON THE LINE PRINTER.
C OUTPUT IS SPOOLED AND ENTERED INTO THE PRINT QUEUE BY PRINTS
C
C
C AAR ==============================================================
C AAR
C AAR
C AAR *** AAR UPDATES MADE BY W.E.BARKER ***
C AAR *** 10/10/77 TO RUN ON DEC-20 ***
C AAR
C AAR CHANGES: DONT PRINT BY CALLING THE "PRINTS" ROUTINE
C AAR (IT HANGS). INSTEAD, PRINT THE FILE BY
C AAR USING THE DISPOSE='LIST' OPTION OF THE
C AAR CLOSE STATEMENT.
C AAR
C AAR NOTE: AAR CHANGES ARE IDENTIFIED BY "AAR" IN LEFT MARGIN
C AAR OF COMMENT LINE. ORIGINAL LINES THAT HAVE BEEN
C AAR COMMENTED OUT ARE IDENTIFIED BY "WMU" IN THE LEFT
C AAR MARGIN.
C AAR
C AAR
C AAR ==============================================================
C
C
C
SUBROUTINE PRINT
DIMENSION LV(125),NNS(18,6),IOUT(133),LOUT(10),IFTOUT(24)
DIMENSION X(3),ID(12500),D(12500),IADD(125),IWO(125)
DIMENSION SOCSC(9),IFMT(24,25),IFT(120),AOUT(10),MOUT(8)
EQUIVALENCE (LV,NNS),(D,ID),(MISS,AMISS),(IFT(90),IFTOUT)
EQUIVALENCE (LOUT,AOUT)
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
COMMON /DEV/ IDLG,ICC,IBNK,IUPGR,ITMPRY
COMMON /VAR/ LICVR,NHV,IV(2,20)
COMMON /OBS/ LICOB,NHO,IO(2,20)
COMMON /SEL/ NS,ISEL(5,20),IDATA(20,20)
COMMON /IDINFO/ LICID,LICIN,LICWO
DOUBLE PRECISION BNKNM,DATCR,ISSEC,DATRN
DATA MISS /"400000000000/
CALL DATE(DATRN)
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='PRINT.DAT',ACCESS='SEQOUT')
NLPP=59
NPAGE=1
LINHD=0
NUMBRV=0
DO 101 I=1,NHV
101 NUMBRV=NUMBRV+IV(2,I)-IV(1,I)+1
NUMBRV=NUMBRV+NS
IF(NUMBRV.LE.200) GO TO 100
WRITE(IDLG,99)
99 FORMAT(' NO MORE THAN 200 VARIABLES IN A PRINT INSTRUCTION')
RETURN
100 LND=12500/NUMBRV-2
IF(LND.GT.125) LND=125
JND=LND+2
C
C
C
IBLK=0
J=1
M=NS
NOBASE=(NO+124)/125
IBASE=NOBASE*NV+1
C
C INFO HEADER
C
200 WRITE(IUPGR,113) DATRN,NPAGE
113 FORMAT('1BANK - WMU',10X,A9,93X,'PAGE ',I5)
NPAGE=NPAGE+1
NLINES=1
IF(LICWO.EQ.1) GO TO 202
READ(IBNK#1) LV
WRITE(IUPGR,201) BNKNM,LV(1),LV(2),LV(4),LV(5),LV(6),LV(7)
201 FORMAT('0BANK ',A10,10X,' CONTAINS ',I5,' VARIABLES AND',
1I6,' OBSERVATIONS, CREATED ON ',2A5/40X,O6,', ',O6,' IS ',
2'RESPONSIBLE FOR ITS CONTENT')
NLINES=NLINES+3
202 WRITE(IUPGR,203)
203 FORMAT('0',2X,' VARIABLE'/' NAME',3X,'NUMBER',3X,'MODE',
15X,'DATA DESCRIPTION')
NLINES=NLINES+3
DO 205 J=1,NHV
K=IV(1,J)
206 NBLK=(K+5)/6+IBASE
M=M+1
IF(NBLK.EQ.IBLK) GO TO 208
READ(IBNK#NBLK) LV
IBLK=NBLK
208 IONE=K-((K-1)/6)*6
ID(M*JND)=NNS(10,IONE)
ID(M*JND-1)=NNS(1,IONE)
IF(NNS(1,IONE).NE.'SOCSC') GO TO 211
IF(NNS(10,IONE).NE.2) GO TO 211
IF(M.EQ.(NS+1)) GO TO 211
DO 212 L=NS+1,M-1
IF(ID(L*JND-1).NE.'SOCSC') GO TO 212
WRITE(IDLG,213)
213 FORMAT(' SOCIAL SECURITY NUMBER MAY ONLY BE LISTED ONCE IN PRINT')
RETURN
212 CONTINUE
211 MODE='FLOAT'
IF(NNS(10,IONE).EQ.1) MODE='ALPHA'
IF(NNS(10,IONE).EQ.2) MODE='FIXED'
WRITE(IUPGR,209)NNS(1,IONE),K,MODE,(NNS(L,IONE),L=2,9)
209 FORMAT(1X,A5,2X,I4,5X,A5,4X,8A5)
NLINES=NLINES+1
IF(NLINES.LE.NLPP) GO TO 210
WRITE(IUPGR,113) DATRN,NPAGE
WRITE(IUPGR,203)
NPAGE=NPAGE+1
NLINES=4
210 K=K+1
IF(K.LE.IV(2,J)) GO TO 206
205 CONTINUE
IF(LICIN.EQ.1) GO TO 300
C
C
102 DO 103 I=1,NUMBRV-NS,8
M=(I+7)/8
K=I+7
IF(K.GT.(NUMBRV-NS)) K=NUMBRV-NS
DO 104 L=1,120
104 IFT(L)=' '
IFT(1)='('
IFT(2)='1'
IFT(3)='0'
IFT(4)='X'
IFT(5)=','
L=6
IF(I.NE.1) GO TO 108
IFT(2)=1H'
IFT(3)='0'
IFT(4)=1H'
IFT(5)=','
IFT(7)='I'
IFT(8)='7'
IFT(9)=','
IFT(10)='2'
IFT(11)='X'
IFT(12)=','
L=13
108 DO 105 J=I,K
MM=ID((NS+J)*JND)
IF(MM.NE.0) GO TO 106
IFT(L)='G'
IFT(L+1)='1'
IFT(L+2)='4'
IFT(L+3)='.'
IFT(L+4)='7'
IFT(L+5)=','
IFT(L+6)='1'
IFT(L+7)='X'
IFT(L+8)=','
L=L+9
GO TO 105
106 IF(MM.NE.1) GO TO 107
IFT(L)='5'
IFT(L+1)='X'
IFT(L+2)=','
IFT(L+3)='A'
IFT(L+4)='5'
IFT(L+5)=','
IFT(L+6)='5'
IFT(L+7)='X'
IFT(L+8)=','
L=L+9
GO TO 105
107 IF(MM.NE.2) PAUSE 'ERROR'
IF(ID((NS+J)*JND-1).EQ.'SOCSC') GO TO 109
IFT(L)='I'
IFT(L+1)='1'
IFT(L+2)='3'
IFT(L+3)=','
IFT(L+4)='2'
IFT(L+5)='X'
IFT(L+6)=','
L=L+7
GO TO 105
109 IFT(L)='A'
IFT(L+1)='3'
IFT(L+2)=','
IFT(L+3)=1H'
IFT(L+4)='-'
IFT(L+5)=1H'
IFT(L+6)=','
IFT(L+7)='A'
IFT(L+8)='2'
IFT(L+9)=','
IFT(L+10)=1H'
IFT(L+11)='-'
IFT(L+12)=1H'
IFT(L+13)=','
IFT(L+14)='A'
IFT(L+15)='4'
IFT(L+16)=','
IFT(L+17)='4'
IFT(L+18)='X'
IFT(L+19)=','
L=L+20
105 CONTINUE
IFT(L-1)=')'
ENCODE(120,110,IFMT(1,M)) IFT
110 FORMAT(132A1)
IZERO=0
103 CONTINUE
WRITE(IUPGR,113) DATRN,NPAGE
NPAGE=NPAGE+1
NLINES=1
NLPO=(NUMBRV-NS+15)/8
IF(LICWO.EQ.1) GO TO 111
CALL HEADR(ID,NS,NUMBRV,JND,IOUT,IUPGR)
NLINES=NLINES+NLPO+1
C
C RETRIEVE AND CALCUALTE ADRESSES
C
111 I=1
120 K=IO(1,I)
IBASE=(K+124)/125
KK=(IBASE-1)*125
N=1
121 IWO(N)=K-KK
IADD(N)=K
K=K+1
IF(K.LE.IO(2,I)) GO TO 122
I=I+1
IF(I.GT.NHO) GO TO 124
K=IO(1,I)
122 LBASE=(K+124)/125
IF(LBASE.NE.IBASE) GO TO 123
N=N+1
IF(N.LE.LND) GO TO 121
N=N-1
123 IO(1,I)=K
C
C SELECT DATA
C
124 IF(NS.LT.1) GO TO 130
DO 125 J=1,NS
KK=(J-1)*JND
LBLK=(ISEL(2,J)-1)*NOBASE+IBASE+1
READ(IBNK#LBLK) LV
DO 126 M=1,N
126 ID(KK+M)=LV(IWO(M))
125 CONTINUE
C
C NOWDATA
C
130 L=NS
DO 131 J=1,NHV
K=IV(1,J)
132 LBLK=(K-1)*NOBASE+IBASE+1
READ(IBNK#LBLK) LV
KK=L*JND
DO 133 M=1,N
133 ID(KK+M)=LV(IWO(M))
L=L+1
K=K+1
IF(K.LE.IV(2,J)) GO TO 132
131 CONTINUE
C
C NOW CHECK TO SEE WHAT SHOULD BE KEPT
C
DO 149 J=1,N
IF(NS.LT.1) GO TO 157
K=1
140 LLN=(K-1)*JND+J
IF(ISEL(3,K).NE.1) GO TO 141
DO 144 M=1,ISEL(5,K)
IF(IDATA(K,M).EQ.MISS) GO TO 143
144 CONTINUE
141 IF(ID(LLN).NE.MISS) GO TO 143
GO TO 146
143 GO TO (151,152,153,154,155,156) ISEL(3,K)
151 DO 145 M=1,ISEL(5,K)
IF(ID(LLN).EQ.IDATA(K,M)) GO TO 142
145 CONTINUE
GO TO 146
152 IF(ID(LLN).LT.IDATA(K,1)) GO TO 142
GO TO 146
153 IF(ID(LLN).LE.IDATA(K,1)) GO TO 142
GO TO 146
154 IF(ID(LLN).GT.IDATA(K,1)) GO TO 142
GO TO 146
155 IF(ID(LLN).GE.IDATA(K,1)) GO TO 142
GO TO 146
156 IF(ID(LLN).NE.IDATA(K,1)) GO TO 142
GO TO 146
146 K=K+1
IF(K.GT.NS) GO TO 149
IF(ISEL(1,K).EQ.ISEL(1,K-1)) GO TO 140
GO TO 149
142 K=K+1
IF(K.GT.NS) GO TO 157
IF(ISEL(1,K).EQ.ISEL(1,K-1)) GO TO 142
GO TO 140
C
C OUTPUT NOW
C
157 IF((NLINES+NLPO).LE.NLPP) GO TO 165
WRITE(IUPGR,113) DATRN,NPAGE
NPAGE=NPAGE+1
NLINES=1
IF(LICWO.EQ.1) GO TO 165
CALL HEADR(ID,NS,NUMBRV,JND,IOUT,IUPGR)
NLINES=NLINES+NLPO+1
165 DO 160 K=NS+1,NUMBRV,8
MM=(K-NS+7)/8
KEND=K+7
IF(KEND.GT.NUMBRV) KEND=NUMBRV
MDAT=0
M=0
MZ=0
DO 161 L=K,KEND
MZ=MZ+1
M=M+1
MOUT(MZ)=0
LOUT(M)=ID((L-1)*JND+J)
IF(LOUT(M).NE.MISS) GO TO 169
MDAT=1
MOUT(MZ)=1
169 IF(ID(L*JND-1).NE.'SOCSC') GO TO 161
IF(ID(L*JND).NE.2) GO TO 161
ENCODE(9,167,ISSEC) LOUT(M)
167 FORMAT(I9)
DECODE(9,168,ISSEC) SOCSC
168 FORMAT(9A1)
LOUT(M)=' '
LOUT(M+1)=' '
LOUT(M+2)=' '
ENCODE(3,168,LOUT(M))(SOCSC(KK),KK=1,3)
ENCODE(2,168,LOUT(M+1))(SOCSC(KK),KK=4,5)
ENCODE(4,168,LOUT(M+2))(SOCSC(KK),KK=6,9)
M=M+2
161 CONTINUE
DO 166 L=1,24
166 IFTOUT(L)=IFMT(L,MM)
IF(MDAT.EQ.1) GO TO 162
IF(K.NE.(NS+1)) WRITE(IUPGR,IFTOUT)(AOUT(KK),KK=1,M)
IF(K.EQ.(NS+1)) WRITE(IUPGR,IFTOUT)IADD(J),(AOUT(KK),KK=1,M)
GO TO 160
162 DO 158 L=1,133
158 IOUT(L)=' '
IF(K.NE.(NS+1)) ENCODE(133,IFTOUT,IFT)(AOUT(KK),KK=1,M)
IF(K.EQ.(NS+1)) ENCODE(133,IFTOUT,IFT) IADD(J),(AOUT(KK),KK=1,M)
DECODE(133,163,IFT) IOUT
163 FORMAT(133A1)
DO 164 L=1,KEND-K+1
IF(MOUT(L).NE.1) GO TO 164
M=11+(L-1)*15
IOUT(M)=' '
IOUT(M+1)='M'
IOUT(M+2)='I'
IOUT(M+3)='S'
IOUT(M+4)='S'
IOUT(M+5)='I'
IOUT(M+6)='N'
IOUT(M+7)='G'
IOUT(M+8)=' '
IOUT(M+9)='D'
IOUT(M+10)='A'
IOUT(M+11)='T'
IOUT(M+12)='A'
IOUT(M+13)=' '
IOUT(M+14)=' '
164 CONTINUE
WRITE(IUPGR,163) IOUT
160 CONTINUE
NLINES=NLINES+NLPO
149 CONTINUE
IF(I.LE.NHO) GO TO 120
C WMU
C WMU
C WMU 300 CALL RELEAS (IUPGR)
C WMU NPAGE=NPAGE+3
C WMU CALL PRINTS('PRINT.DAT',2,1,1,NPAGE)
C WMU
C
C
C AAR
C AAR *** AAR CHANGE ***
C AAR USE THE LIST OPTION TO PRINT.
C AAR
C AAR ----
C AAR !
300 CLOSE(UNIT=IUPGR,DISPOSE='LIST')
C AAR !
C AAR ----
C AAR
C
400 RETURN
END
SUBROUTINE HEADR(ID,NS,NUMBRV,JND,IOUT,IUPGR)
DIMENSION ID(1),IOUT(132)
DO 1 J=NS+1,NUMBRV,8
DO 7 L=1,133
7 IOUT(L)=' '
JEND=J+7
IF(JEND.GT.NUMBRV) JEND=NUMBRV
DO 5 L=J,JEND
K=L*JND
MODE=ID(K)+1
M=12+(L-J)*15
GO TO (2,3,4),MODE
PAUSE 'PROBLEM'
2 M=M+2
GO TO 8
3 M=M+5
GO TO 8
4 M=M+8
IF(ID(K-1).EQ.'SOCSC') M=M-5
8 DECODE(5,6,ID(K-1))(IOUT(I),I=M,M+4)
6 FORMAT(5A1)
5 CONTINUE
IF(J.EQ.(NS+1)) IOUT(1)='0'
IF(JEND.NE.NUMBRV) GO TO 10
IOUT(5)='O'
IOUT(6)='B'
IOUT(7)='S'
IOUT(8)='.'
10 WRITE(IUPGR,9) IOUT
9 FORMAT(133A1)
1 CONTINUE
DASH='-----'
L=8
IF((NUMBRV-NS).LT.8) L=NUMBRV-NS
L=L*3
WRITE(IUPGR,11)(DASH,I=1,L)
11 FORMAT(1X,7('-'),2X,24A5)
RETURN
END