Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

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