Google
 

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