Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bank/bnk10.ban
There are 3 other files named bnk10.ban in the archive. Click here to see a list.
C *** BANK ***
C
C SUBROUTINE TO DELETE VARIABLE OR OBSERVATIONS. ALL PERTINANT
C INFORMATION REGUARDING THE BANK SIZE AND DICTIONARY STUFF WILL
C BE CHANGED.
C
SUBROUTINE DELET (IWHERE)
DIMENSION ISAMP(125),NNS(18,6),IOUT(125)
DIMENSION NNSO(18,6),ISLTD(125,20),IADD(125)
DIMENSION ISLECT(125)
COMMON /DEV/IDLG,ICC,IBNK,IUPGR,ITMPRY
COMMON /VAR/ LICVR,NHV,IV(2,30)
COMMON /OBS/ LICOB,NHO,IO(2,30)
COMMON /SEL/NS,ISEL(5,20),IDATA(20,20)
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
COMMON /SET/ NHVSET,IVSET(2,30), NHOSET,IOSET(2,30)
EQUIVALENCE (MISS,AMISS),(NNS,ISAMP),(NNSO,IOUT)
DOUBLE PRECISION BNKNM
DATA MISS /"400000000000/
NOBASE=(NO+124)/125
IWHERE=0
3 IF((NHV.EQ.1).AND.(IV(1,1).EQ.1).AND.(IV(2,1).EQ.NV)) GO TO 5
IF((NHO.EQ.1).AND.(IO(1,1).EQ.1).AND.(IO(2,1).EQ.NO)) GO TO 7
WRITE(IDLG,4)
4 FORMAT('VARIABLE AND OBSERVATION MAY NOT BE USED TOGETHER TO ',
1'DELETE')
RETURN
5 IF((NHO.NE.1).OR.(IO(1,1).NE.1).OR.(IO(2,1).NE.NO)) GO TO 30
IF(NS.GE.1) GO TO 30
18 CLOSE(UNIT=IBNK,DISPOSE='DELETE')
WRITE(IDLG,6)
6 FORMAT(' ENTIRE BANK DELETED')
NO=0
NV=0
IWHERE=2
RETURN
7 IF(NS.LT.1) GO TO 9
WRITE(IDLG,8)
8 FORMAT('SELECT MAY ONLY BE USED TO DELETE OBSERVATIONS')
RETURN
C
C DELETE 1 OR MORE VARIABLES (WILL ONLY DELETE THOSE VARIABLES
C NAMED)
C
9 NTOT=0
DO 10 I=1,NHV
10 NTOT=NTOT+IV(2,I)-IV(1,I)+1
OPEN(UNIT=IUPGR,DEVICE='DSK',ACCESS='SEQOUT',FILE='TMPRY.DAT',
1MODE='BINARY',RECORD SIZE=126)
READ(IBNK#1) ISAMP
ISAMP(1)=ISAMP(1)-NTOT
WRITE(IUPGR) ISAMP
DO 12 J=1,NV
DO 13 K=1,NHV
IF((J.GE.IV(1,K)).AND.(J.LE.IV(2,K))) GO TO 12
13 CONTINUE
DO 11 I=1,NOBASE
IREC=(J-1)*NOBASE+I+1
READ(IBNK#IREC) ISAMP
WRITE(IUPGR) ISAMP
11 CONTINUE
12 CONTINUE
NBLK=NOBASE*NV+1
M=1
DO 14 I=1,NV,6
L=NBLK+(I+5)/6
READ(IBNK#L) ISAMP
DO 15 J=I,I+5
IF(J.GT.NV) GO TO 15
DO 16 K=1,NHV
IF((J.GE.IV(1,K)).AND.(J.LE.IV(2,K))) GO TO 15
16 CONTINUE
L=J-I+1
DO 17 K=1,18
17 NNSO(K,M)=NNS(K,L)
M=M+1
IF(M.LE.6) GO TO 15
WRITE(IUPGR) IOUT
M=1
15 CONTINUE
14 CONTINUE
IF(M.NE.1) WRITE(IUPGR) IOUT
NV=NV-NTOT
NHVSET=1
IVSET(1,1)=1
IVSET(2,1)=NV
GO TO 82
C
C DELETE OBSERVATION
C
30 OPEN(UNIT=ITMPRY,DEVICE='DSK',ACCESS='SEQOUT',FILE='LIST.DAT',
1MODE='BINARY',RECORD SIZE=126)
NOBASE=(NO+124)/125
M=1
MTOT=0
DO 31 I=1,NOBASE
LMIN=(I-1)*125
LBEG=LMIN+1
LEND=LBEG+124
IF(LEND.GT.NO) LEND=NO
DO 32 J=1,125
32 ISAMP(J)=0
DO 33 L=1,NHO
IF((IO(1,L).GT.LEND).OR.(IO(2,L).LT.LBEG)) GO TO 33
KSTART=LBEG
IF(IO(1,L).GT.LBEG) KSTART=IO(1,L)
KEND=LEND
IF(IO(2,L).LT.LEND) KEND=IO(2,L)
DO 34 K=(KSTART-LMIN),(KEND-LMIN)
34 ISAMP(K)=1
33 CONTINUE
IF(NS.LT.1) GO TO 47
DO 35 J=1,NS
IBLK=(ISEL(2,J)-1)*NOBASE+I+1
READ(IBNK#IBLK)(ISLTD(K,J),K=1,125)
35 CONTINUE
DO 36 K=1,LEND-LMIN
IF(ISAMP(K).EQ.0) GO TO 36
J=1
48 IF(ISEL(3,J).NE.1) GO TO 49
DO 70 MM=1,ISEL(5,J)
IF(IDATA(J,MM).EQ.MISS) GO TO 40
70 CONTINUE
49 IF(ISLTD(K,J).EQ.MISS) GO TO 39
40 GO TO (41,42,43,44,45,46) ISEL(3,J)
41 DO 71 MM=1,ISEL(5,J)
IF(ISLTD(K,J).EQ.IDATA(J,MM)) GO TO 37
71 CONTINUE
GO TO 39
42 IF(ISLTD(K,J).LT.IDATA(J,1)) GO TO 37
GO TO 39
43 IF(ISLTD(K,J).LE.IDATA(J,1)) GO TO 37
GO TO 39
44 IF(ISLTD(K,J).GT.IDATA(J,1)) GO TO 37
GO TO 39
45 IF(ISLTD(K,J).GE.IDATA(J,1)) GO TO 37
GO TO 39
46 IF(ISLTD(K,J).NE.IDATA(J,1)) GO TO 37
39 J=J+1
IF(J.GT.NS) GO TO 72
IF(ISEL(1,J).EQ.ISEL(1,J-1)) GO TO 48
72 ISAMP(K)=0
GO TO 36
37 J=J+1
IF(J.GT.NS) GO TO 36
IF(ISEL(1,J).EQ.ISEL(1,J-1)) GO TO 37
GO TO 48
36 CONTINUE
47 DO 50 K=1,LEND-LMIN
IF(ISAMP(K).EQ.1) GO TO 50
IOUT(M)=K+LMIN
M=M+1
IF(M.LE.125) GO TO 50
WRITE(ITMPRY) IOUT
MTOT=MTOT+125
M=1
50 CONTINUE
31 CONTINUE
IOUT(M)=0
MTOT=MTOT+M-1
WRITE(ITMPRY) IOUT
CALL RELEAS(ITMPRY)
OPEN(UNIT=ITMPRY,DEVICE='DSK',FILE='LIST.DAT',ACCESS='RANDIN',
1MODE='BINARY',RECORD SIZE=126)
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='TMPRY.DAT',ACCESS='SEQOUT',
1MODE='BINARY',RECORD SIZE=126)
READ(IBNK#1) IADD
IADD(2)=MTOT
WRITE(IUPGR) IADD
DO 52 J=1,NV
LBLK=(J-1)*NOBASE+1
IBLK=0
KK=1
53 READ(ITMPRY#KK) IOUT
I=1
55 IF(I.GT.125) GO TO 59
IF(IOUT(I).EQ.0) GO TO 56
NBLK=(IOUT(I)+124)/125
IF(IBLK.EQ.NBLK) GO TO 54
IREC=LBLK+NBLK
READ(IBNK#IREC) IADD
IBLK=NBLK
IBLKSB=(NBLK-1)*125
54 ITEM=IOUT(I)-IBLKSB
ISAMP(I)=IADD(ITEM)
I=I+1
GO TO 55
56 IF(I.EQ.1) GO TO 52
57 DO 58 K=I,125
58 ISAMP(K)=MISS
59 WRITE(IUPGR) ISAMP
KK=KK+1
IF(I.GT.125) GO TO 53
52 CONTINUE
IBASE=NV*NOBASE+1
IKLK=(NV+5)/6
DO 60 I=1,IKLK
READ(IBNK#(IBASE+I)) IADD
WRITE(IUPGR) IADD
60 CONTINUE
NO=MTOT
NHOSET=1
IOSET(1,1)=1
IOSET(2,1)=NO
CLOSE(UNIT=ITMPRY,DISPOSE='DELETE')
82 CLOSE(UNIT=IBNK,DISPOSE='RENAME',FILE='BACKUP.BAN')
CLOSE(UNIT=IUPGR,DISPOSE='RENAME',FILE=BNKNM,PROTECTION="155)
OPEN(UNIT=IBNK,FILE='BACKUP.BAN')
CLOSE(UNIT=IBNK,DISPOSE='DELETE')
IWHERE=1
RETURN
END