C   07/06/96 606071858  MEMBER NAME  NEWOLD1  (S4)          FORTRAN
      SUBROUTINE BCFILE(LUN,NRECA,NBLOCK,IPASS,IOPT)
      COMMON/ACS/DUMMI(90),NUNTB
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
C
C     IUND   =   UNIT
C     INDT   =   INDEX OF DIRECTOTY ENTRY
C     INDC   =   INDEX OF BANK TO BE COPIED
C     NPTR   =   RECORD NR WITH DATA
C     INDA   =   INDEX OF MASTER DIRECTORY BANK
C     LISTE  =   NAME, NR, DATA RECORD NR, NR OF WORDS
C     IPAS   =   PASSWORD
C     NDAREC =   NR OF WORDS/RECORD
C
      REAL*8 DATE(2)
      INTEGER IOPNEW/3HNEW/,IOPOLD/3HOLD/,IOP0LD/3H0LD/,DIRA/4H+DIR/
C
C     FORMAT AND CONTENT OF MASTER DIRECTORY RECORD (RECORD NR 1)
C
C     INDEX      CONTENT
C     ---------- ----------------
C         1      = 49
C         2      = 'DIRA'
C         3      = 0
C         4      = 0
C         5      = 45
C         6      TOTAL NR OF RECORDS
C         7      NR OF USED RECORD
C         8      NPRIME FOR HASH FUNCTION
C         9      = 0 OR NAME OF ADDED/CHANGED BANK
C        10      = 0 OR NR OF ADDED/CHANGED BANK
C        11      NR OF WORDS/RECORD
C        12      = 0 OR (DAY) TIME OF UPDATE IN 1/100 SEC
C        13
C        14
C        15
C        16
C        17
C        18
C        19      (PASSWORD)
C        20      = 0 CHANGES ALLOWED, = 1 CHANGES NOT ALLOWED
C     21-24      DATE/TIME OF LAST LOAD
C     25-28      DATE/TIME OF LAST UPDATE
C     29-32      DATE/TIME OF LAST UNLOAD
C        33      NR OF BANKS AT LAST LOAD
C        34      NR OF BANKS AT LAST UPDATE
C        35      NR OF BANKS AT LAST UNLOAD
C         .
C        50
C     ---------- ----------------
C        51      PRINTOUT COUNTER
C        52
C
C
C
C     FORMAT AND CONTENT OF DIRECTORY RECORDS (RECORD NRS 2, 3 ...)
C
C     INDEX      CONTENT
C     ---------- ----------------
C         1      = 4 + 3*NE        FOR NE ENTRIES
C         2      = 'DIRA'
C         3      = 0
C         4      = 0
C     ---------- ----------------
C         5      NAME
C         6      NR
C         7      NR OF DATA RECORD
C         8      NR OF WORDS
C         9      NAME ETC
C        10
C        11
C        12
C        13
C        14
C        15
C
      NREC=NRECA
      IOP=0
      IF(IOPT.EQ.IOPNEW) IOP=1
      IF(IOPT.EQ.IOPOLD) IOP=2
      IF(IOPT.EQ.IOP0LD) IOP=2
      CALL DAY(DATE(1),DATE(2))
      IF(NUNTB.NE.0) WRITE(NUNTB,101) LUN,NREC,NBLOCK,IPASS,IOPT
      IF(IOP.EQ.0) GOTO 201
      IUND=LUN
      IPAS=IPASS
      IF(IOP.EQ.1) GOTO  10
C
C     OLD DATA SET / CHECK NR OF RECORDS AND NR OF WORDS/RECORD
C
      CALL DIDA(0,LISTE,1)
C
C     'OLD BOS' DATA SET IS INDICATED BY NREC=-1610
C
      IF(NREC+1610.EQ.0) NREC=IW(INDA+6)
      IF(NUNTB.NE.0) WRITE(NUNTB,101) LUN,NREC,NBLOCK,IPASS,IOPT
      IF(IW(INDA+6).NE.NREC)    GOTO 203
      IF(IW(INDA+11).NE.NBLOCK) GOTO 203
      IF(IW(INDA+20).NE.0)      GOTO 203
      IW(INDA+34)=0
      GOTO 12
C
C     DETERMINE PRIME NUMBER FOR HASH SEARCH ALGORITHM
C
   10 IF(NUNTB.NE.0) WRITE(NUNTB,101) LUN,NREC,NBLOCK,IPASS,IOPT
      INDA=IBANK(4H+DIR,IUND,2HDL)
      INDA=IBANK(4H+DIR,IUND,52)
      IF(INDA.EQ.0) GOTO 204
   12 NPRIME=NREC/20
      IF(NPRIME.LE.5) NPRIME=5
      NPRIME=(NPRIME/2)*2+1
      NPRIME=NPRIME-2
   14 NPRIME=NPRIME+2
      A=NPRIME
      J=SQRT(A)
      DO 16 K=3,J,2
      NDIV=NPRIME/K
      IF(NDIV*K.EQ.NPRIME) GOTO 14
   16 CONTINUE
C
C     INITIAL DEFINITION OF THE FIRST RECORD
C
      IW(INDA+1)=4
      IW(INDA+2)=DIRA
      IW(INDA+3)=0
      IW(INDA+4)=0
      IW(INDA+5)=0
      IW(INDA+6)=NREC
      IW(INDA+7)=NPRIME+2
      IW(INDA+8)=NPRIME
      IW(INDA+9)=0
      IW(INDA+10)=0
      IW(INDA+11)=NBLOCK
      IW(INDA+19)=IPASS
      CALL DAY(DATE(1),DATE(2))
      CALL UCOPY(DATE,IW(INDA+21),4)
      IF(IOP.EQ.1) CALL UCOPY(DATE,IW(INDA+25),4)
      IF(IOP.EQ.1) CALL UCOPY(DATE,IW(INDA+29),4)
C
C     WRITE EMPTY DIRECTORY RECORDS
C
      DO 18 K=1,NPRIME
      IW(INDA+3)=K+1
   18 CALL WRDA(K+1,IW(INDA+1),IW(INDA+2))
C
C     WRITE EMPTY NEXT RECORD
C
      IW(INDA+1)=0
      CALL WRDA(NPRIME+2,IW(INDA+1),IW(INDA+2))
C
C     DEFINE AND WRITE MASTER DIRECTORY RECORD
C
      IW(INDA+1)=49
      IW(INDA+3)=0
      IW(INDA+5)=45
      CALL WRDA(1,IW(INDA+1),IW(INDA+2))
C
C     MAKE PRINTOUT AND DELETE MASTER DIRECTORY BANK
C
      INDA=IBANK(4H+DIR,IUND,2HDL)
      IPAS=IPASS
      CALL DIDA(0,LISTE,1)
      CALL BGAR(IGA)
C
C
C
  100 RETURN
  101 FORMAT('0---- DIR-UNIT',I3,9X,'INITIALIZE/CLEAR',I8,' RECORDS *',
     1   I5,' WORDS, PASSWORD = ',A4,'   OPTION = ',A4,4X,'(BCFILE)')
C
C     ILLEGAL ARGUMENT IN BCFILE
C
  201 CALL BDMPA(201)
C
C     DIFFERENCE IN DATA SET
C
  203 CALL BDMPA(203)
C
C     INSUFFICIENT SPACE FOR DIRECTORY BANK
C
  204 CALL BDMPA(204)
      GOTO 100
      END
      SUBROUTINE BPWDIR(LUN,IPASS)
      COMMON/ACS/DUMMI(90),NUNTB
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      IND=IBANK(4H+DIR,LUN,2HDL)
      IUND=LUN
      IPAS=IPASS
      CALL DIDA(0,LISTE,1)
  100 RETURN
      END
      FUNCTION INDDIR(NAME,NR,IUNIT,IOPT)
      COMMON/ACS/DUMMI(90),NUNTB
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      REAL*8 DATE(2)
      INTEGER IPR/0/,IOPTL(4)/2HFE,2HDL,2HST,2HFU/,NAMUN/4H+U00/
C
C     DIRECT ACCESS FUNCTION
C
      INDDIR=0
      IUND=IUNIT
      DO 10 IOP=1,4
      IF(IOPT.EQ.IOPTL(IOP)) GOTO 12
   10 CONTINUE
      GOTO 100
   12 LISTE(1)=NAME
      LISTE(2)=NR
      IF(IOP.EQ.4) GOTO 20
      IF(IOP-2) 20,30,40
C
C     FETCH FROM DIRECT ACCESS DATA SET
C
   20 INDC=ILINK(LISTE(1),LISTE(2))
      IF(INDC.NE.0) GOTO 90
      CALL DIDA(1,LISTE,1)
      IF(INDT.EQ.0) GOTO 100
      IF(IOP.NE.4) GOTO 26
   22 IND=IBLN(LISTE(1))
      IND=IW(IND)
      IF(IND.EQ.0) GOTO 26
      IF(IW(IND-1).EQ.0) GOTO 24
      IND=IBANK(LISTE(1),IW(IND-2),'DL')
      GOTO 22
   24 IND=ILINK(LISTE(1),IW(IND-2))
      IF(IW(IND).NE.LISTE(4)) GOTO 25
      INDC=IBANK(LISTE(1),LISTE(2),'RN')
      GOTO 28
   25 IND=IBANK(LISTE(1),IW(IND-2),'DL')
   26 INDC=IBANK(LISTE(1),LISTE(2),LISTE(4))
   28 IF(INDC.EQ.0) GOTO 100
      CALL DAFR(1)
      GOTO 90
C
C     DELETE BANK ON DIRECT ACCESS DATA SET
C
   30 JD=-1
C
C     MAKE SURE DIRECTORY BANK IS THERE AND CHECK PASSWORD
C
      CALL DIDA(0,LISTE,1)
      IF(IW(INDA+20).NE.0) GOTO 100
C
C     RESERVE DATA SET EXCLUSIVELY
C
      CALL DIDA(-1,LISTE,1)
C
C     CHECK, THAT BANK TO BE DELETED IS THERE
C
      CALL DIDA(1,LISTE,1)
      IF(INDT.NE.0) GOTO 35
      CALL WRDA(1,IW(INDA+1),IW(INDA+2))
      GOTO 100
   35 NPTR=IW(INDT+3)
C
C     DELETE BANK ON DATA SET AND IN DIRECTORY
C
      CALL DAFR(2)
      CALL DIDA(2,LISTE,1)
C
C     UPDATE BANK COUNTER AND PRINT
C
      IW(INDA+51)=IW(INDA+51)+1
      IF(NUNTB.EQ.0) GOTO 70
      IF(IW(INDA+51).LE.100) WRITE(NUNTB,104) IUND,LISTE(1),LISTE(2)
      IF(IW(INDA+51).EQ.100) WRITE(NUNTB,109) IUND
      GOTO 70
C
C     STORE BANK ON DIRECT ACCESS DATA SET
C
   40 JD=1
      INDC=ILINK(LISTE(1),LISTE(2))
      IF(INDC.EQ.0) GOTO 85
      IF(IW(INDC).LE.0) GOTO 85
      IF(IW(INDC).GT.3200) GOTO 85
C
C     MAKE SURE DIRECTORY BANK IS THERE AND CHECK PASSWORD
C
      CALL DIDA(0,LISTE,1)
      IF(IW(INDA+20).NE.0) GOTO 100
C
C     RESERVE DATA SET EXCLUSIVELY
C
      CALL DIDA(-1,LISTE,1)
C
C     SEARCH DIRECTORY FOR BANK
C
      CALL DIDA(1,LISTE,1)
C
C     CHECK TOTAL SPACE ON DATA SET
C
      IF(IW(INDA+7)+2+IW(INDC)/NDAREC.GT.IW(INDA+6)) GOTO 201
      ICO=1
      IF(INDT.EQ.0) GOTO 50
C
C     BANK IS ALREADY ON DATA SET
C
      IW(INDA+34)=IW(INDA+34)-1
      ICO=2
      IF(IW(INDC).EQ.LISTE(4)) GOTO 52
C
C     DELETE BANK ON DATA SET AND IN DIRECTORY
C
      CALL DAFR(2)
      CALL DIDA(2,LISTE,1)
C
C     ADD BANK TO DATA SET AND DIRECTORY
C
   50 CALL DAFR(3)
      CALL DIDA(3,LISTE,1)
      GOTO 54
C
C     INSERT BANK IN SAME PLACE ON DATA SET
C
   52 CALL DAFR(4)
C
C     UPDATE COUNTER AND PRINT
C
   54 IW(INDA+51)=IW(INDA+51)+1
      IF(IW(INDA+51).GT.100) GOTO 70
      GOTO (60,62),ICO
   60 IF(NUNTB.NE.0) WRITE(NUNTB,102) IUND,LISTE(1),LISTE(2)
      GOTO 64
   62 IF(NUNTB.NE.0) WRITE(NUNTB,103) IUND,LISTE(1),LISTE(2)
   64 IF(IW(INDA+51).EQ.100.AND.NUNTB.NE.0) WRITE(NUNTB,109) IUND
C
C     UPDATE FIRST DIRECTORY RECORD AND FREE DATA SET
C
   70 CALL DAY(DATE(1),DATE(2))
      CALL UCOPY(DATE,IW(INDA+25),4)
      IW(INDA+34)=IW(INDA+34)+JD
      CALL WRDA(1,IW(INDA+1),IW(INDA+2))
C
C     TWO ADDITIONAL WRITES TO FORCE BUFFER TO BE WRITTEN
C
      CALL WRDA(IW(INDA+6)-1,IW(INDA+1),IW(INDA+2))
      CALL WRDA(IW(INDA+6)  ,IW(INDA+1),IW(INDA+2))
C
C     UPDATE NRDIR BANK
C
      NAMUNT=NAMUN+(IUND/10)*256+MOD(IUND,10)
      IND=ILINK(NAMUNT,LISTE(1))
      IF(IND.EQ.0) GOTO 100
      NW=IW(IND+3)
      IF(NW.GT.3) GOTO 72
      IF(IOP.EQ.2) GOTO 100
      IW(IND+3)=4
      IW(IND+4)=LISTE(2)
      GOTO 100
   72 IF(LISTE(2).LT.IW(IND+4)) GOTO 74
      IF(IOP.EQ.2) GOTO 100
      IW(IND+1)=4
      GOTO 100
   74 DO 76 I=1,NW
      IF(IW(IND+I)-LISTE(2)) 76,78,79
   76 CONTINUE
      IF(IOP.EQ.2) GOTO 100
      IW(IND+2)=NW
      GOTO 100
   78 IF(IOP.EQ.3) GOTO 100
      IF(NW-I.GT.0) CALL UCOPY2(IW(IND+I+1),IW(IND+I),NW-I)
      IW(IND+3)=NW-1
      GOTO 100
   79 IF(IOP.EQ.2) GOTO 100
      IF(NW-I.GT.0) CALL UCOPY2(IW(IND+I),IW(IND+I+1),NW-I)
      IW(IND+I)=LISTE(2)
      IW(IND+2)=NW
      GOTO 100
C
C     PRINT OUT
C
   85 IPR=IPR+1
      IF(IPR.GT.100) GOTO 100
      IF(NUNTB.EQ.0) GOTO 100
      IF(JD.EQ.1) WRITE(NUNTB,107) IW(INDC-3),IW(INDC-2),IW(INDC)
      IF(JD.NE.1) WRITE(NUNTB,108) NAME,NR
      GOTO 100
C
C
   90 INDDIR=INDC
  100 RETURN
C
C     DATA SET SPACE LIMIT REACHED
C
  201 CALL BDMPA(201)
      GOTO 100
  102 FORMAT(' ---- UNIT',I3,' / INDDIR',5X,'BANK (',A4,',',I10,')',1X,
     1   'STORED')
  103 FORMAT(' ---- UNIT',I3,' / INDDIR',5X,'BANK (',A4,',',I10,')',1X,
     1   'REPLACED')
  104 FORMAT(' ---- UNIT',I3,' / INDDIR',5X,'BANK (',A4,',',I10,')',1X,
     1   'DELETED')
  107 FORMAT('0---- INDDIR     UNABLE TO STORE BANK (',A4,',',I10,
     1   ')',I10,' WORDS')
  108 FORMAT('0---- INDDIR     UNABLE TO DELETE BANK (',A4,',',I10,')')
  109 FORMAT(' ---- UNIT',I3,' / INDDIR PRINTOUT SUPPRESSED')
      END
      FUNCTION NRDIR(NAME,NR,IUNIT,IOPT)
      COMMON/ACS/DUMMI(90),NUNTB
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      INTEGER NAMUN/4H+U00/,IOPTL(5)/2HEQ,2HLE,2HLT,2HGE,2HGT/
      NRDIR=0
      IUND=IUNIT
      DO 10 IOP=1,5
      IF(IOPT.EQ.IOPTL(IOP)) GOTO 12
   10 CONTINUE
      GOTO 100
C
C
C
   12 NAMUNT=NAMUN+(IUNIT/10)*256+MOD(IUNIT,10)
      NAMELK=NAME
      NRLK  =NR
      IND=ILINK(NAMUNT,NAMELK)
      IF(IND.EQ.0) GOTO 16
      IF(IW(IND+1).NE.0.AND.NRLK.LT.IW(IND+ 4)) GOTO 16
   13 NW=IW(IND+3)
      IF(IW(IND+2).NE.0.AND.NRLK.GT.IW(IND+NW)) GOTO 16
      IF(NW.LT.4) GOTO 16
      DO 14 I=4,NW
      IF(IW(IND+I)-NRLK) 14,90,92
   14 CONTINUE
      I=NW+1
      GOTO 92
C
C     TRY TO FIND BANK OR NEIGHBOUR DIRECTLY
C
   16 LISTE(1)=NAMELK
      LISTE(2)=NRLK
      CALL DIDA(1,LISTE,1)
      IF(INDT.EQ.0) GOTO 19
      IF(IOP.EQ.3.OR.IOP.EQ.5) GOTO 18
      NRDIR=NRLK
      GOTO 100
   18 IF(IOP.EQ.3) LISTE(2)=LISTE(2)-1
      IF(IOP.EQ.5) LISTE(2)=LISTE(2)+1
      CALL DIDA(1,LISTE,1)
      IF(INDT.EQ.0) GOTO 19
      NRDIR=LISTE(2)
      GOTO 100
C
C
C
   19 NPRIME=IW(INDA+8)
      NFIND=NPRIME/3+5
      NWD=3+8*NFIND
      IND=IBANK(NAMUNT,NAMELK,NWD)
      IF(IND.EQ.0) GOTO 201
C
C     READ ALL DIRECTORY RECORDS AND STORE NUMBERS
C
      LB=3
      ICHA=0
      ICHB=0
      IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 201
      JREC=1
   20 JREC=JREC+1
      IF(JREC.GT.NPRIME+1) GOTO 24
      NREC=JREC
   22 CALL RDDA(NREC,NDAREC,IW(IA))
      NREC=IW(IA+3)
      K=IA+4
      N=IW(K)/4
      IF(N.EQ.0) GOTO 32
      DO 30 I=1,N
      IF(IW(K+1).NE.NAMELK) GOTO 30
      IF(ICHA.NE.0.AND.IW(K+2).LT.IW(IND+ICHA)) GOTO 30
      IF(ICHB.NE.0.AND.IW(K+2).GT.IW(IND+ICHB)) GOTO 30
      LB=LB+1
      IW(IND+LB)=IW(K+2)
      IF(LB.NE.NWD) GOTO 30
   24 IF(LB.EQ.3) GOTO 100
C
C     SORT NUMBERS
C
      CALL SORTAE(IW(IND+4),1,LB-3,1,0)
      DO 26 L=4,LB
      IF(IW(IND+L).GE.NRLK) GOTO 28
   26 CONTINUE
      L=LB
   28 IF(L-NFIND.GE.4)    ICHA=4
      LA=MAX0(4,L-NFIND)
      LB=MIN0(LB,L+3*NFIND)
      CALL UCOPY2(IW(IND+LA),IW(IND+4),LB-LA+1)
      IF(L+3*NFIND.LE.LB) ICHB=4+LB-LA
      LB=4+LB-LA
      IF(JREC.GT.NPRIME+1) GOTO 40
C
C
C
   30 K=K+4
   32 IF(NREC.EQ.0) GOTO 20
      GOTO 22
C
C
C
   40 IW(IND+1)=ICHA
      IW(IND+2)=ICHB
      IW(IND+3)=LB
      IF(LB.LE.3) LB=4
      IND=IBANK(NAMUNT,NAMELK,LB)
      IF(IND.EQ.0) GOTO 201
      GOTO 13
C
C
C
   90 IF(IOP.EQ.3) I=I-1
      IF(IOP.EQ.5) I=I+1
      GOTO 94
   92 IF(IOP.EQ.1) GOTO 100
      IF(IOP.LE.3) I=I-1
   94 IF(I.GE.4) GOTO 96
      IF(IW(IND+1)) 16,100,16
   96 IF(I.LE.IW(IND+3)) GOTO 98
      IF(IW(IND+2)) 16,100,16
   98 NRDIR=IW(IND+I)
C
C
C
  100 RETURN
C
C     ERROR - NOT ENOUGH SPACE FOR FIND BANK
C
  201 CALL BDMPA(47)
      GOTO 100
      END
      SUBROUTINE BFTDIR(LUN,LUN1,IOPT)
      COMMON/ACS/DUMMI(90),NUNTB
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      REAL*8 DATE(2)
      INTEGER IOPFR/2HFR/,IOPTO/2HTO/,IOPT0/2HT0/,BLANK/4H    /
      INTEGER DIRA/'+DIR'/,DIRO/'DIRA'/
      CALL DAY(DATE(1),DATE(2))
      IOP=0
      IF(IOPT.EQ.IOPFR) IOP=1
      IF(IOPT.EQ.IOPTO) IOP=2
      IF(IOPT.EQ.IOPT0) IOP=2
      IF(NUNTB.NE.0) WRITE(NUNTB,101) LUN,LUN1,IOPT
      IF(IOP.EQ.0) GOTO 201
      IUND=LUN
      CALL DIDA(0,LISTE,1)
      IF(INDA.EQ.0) GOTO 202
      IF(IOP.NE.1)  GOTO 20
C
C     OPTION FR=FROM
C
      IF(IW(INDA+34).NE.0) GOTO 201
      IF(IW(INDA+20).EQ.1) GOTO 201
C
C
C
      INDL=IBANK(4H+DIR,-1,2000)
      IF(INDL.EQ.0)     GOTO 201
      INDB=IBANK(4H+DIR,-2,3204)
      IF(INDB.EQ.0)     GOTO 201
      NREC=IW(INDA+6)
      NBK=0
      N=0
      NCT=0
      NERR=0
C
C     READ SEQUENTIAL DATA SET
C
      IF(LUN1.EQ.0) GOTO 18
   10 CALL RDSQ(LUN1,NTOT,IW(INDB+1),&16)
      NCT=NCT+1
      IF(NTOT.LE.0.OR.NTOT.GT.3204) GOTO 12
      IF(NTOT-4.NE.IW(INDB+4)) GOTO 12
      GOTO 14
   12 NERR=NERR+1
      GOTO 10
   14 IF(NCT.EQ.0) GOTO 16
      LISTE(1)=IW(INDB+1)
      LISTE(2)=IW(INDB+2)
      LISTE(3)=0
      LISTE(4)=IW(INDB+4)
      LISTE(5)=2+MOD(IABS(LISTE(1)+LISTE(2)),IW(INDA+8))
      INDC=INDB+4
      CALL DAFR(3)
      CALL UCOPY2(LISTE,IW(INDL+5*N+1),5)
      NBK=NBK+1
      N=N+1
      IF(N.LT.400) GOTO 10
   16 IF(N.EQ.0) GOTO 18
      CALL SORTAE(IW(INDL+1),5,N,5,0)
      CALL DIDA(3,IW(INDL+1),N)
      IF(N.NE.400) GOTO 18
      N=0
      GOTO 10
   18 IW(INDA+33)=NBK
      IW(INDA+34)=NBK
      IW(INDA+35)=NBK
      CALL WRDA(1,IW(INDA+1),IW(INDA+2))
      NCT=NCT-NERR
      IND =IBANK(4H+DIR,-2,2HDL)
      IND =IBANK(4H+DIR,-1,2HDL)
      IPAS=IW(INDA+19)
      INDA=IBANK(4H+DIR,IUNDA,2HDL)
      CALL DIDA(0,LISTE,1)
      CALL BGAR(IGA)
      IF(NUNTB.NE.0) WRITE(NUNTB,102) LUN,NCT,NERR
      IF(LUN1.NE.0) REWIND LUN1
      GOTO 100
C
C     OPTION TO
C
   20 NPAGL=200
      IPAS=0
      INDA=ILINK(4H+DIR,IUND)
      IF(INDA.NE.0) IPAS=IW(INDA+19)
      INDA=IBANK(4H+DIR,IUND,2HDL)
      CALL BGAR(IGA)
C
C     DETERMINE NUMBER OF RECORDS
C
      CALL DIDA(0,LISTE,1)
      IF(INDA.EQ.0) GOTO 203
      NRECL=IW(INDA+7)
      CALL UCOPY(DATE,IW(INDA+29),4)
C
C     PREPARE BANK FOR TABLE OF CONTENT
C
      INDL=IBANK(4H+DIR,-1,450)
      IF(INDL.EQ.0) GOTO 201
      NPG=0
      NE =0
      NERR=0
      NSE=0
      IA=IBANK(0,0,0)
      IF(IW(IA).LE.3204+NDAREC) GOTO 201
      NRC=0
   24 NTOT=0
      IB=IA
   30 NRC=NRC+1
      ISW=0
      IF(NRC.LE.NRECL) GOTO 32
      ISW=2
      GOTO 50
C
C     READ NEXT RECORD FROM DIRECT ACCESS
C
   32 JSAV=IW(IB-1)
      CALL RDDA(NRC,NDAREC,IW(IB-1))
      NTOTN=IW(IB-1)
      IW(IB-1)=JSAV
      IF(NTOTN.EQ.0) GOTO 36
      IF(NTOTN.GT.4.AND.NTOTN.LE.NDAREC-1) GOTO 34
      NERR=NERR+1
      GOTO 24
   34 IF(IW(IB).NE.DIRA.AND.IW(IB).NE.DIRO) GOTO 40
   36 ISW=1
      GOTO 50
   40 NTOT=NTOT+NTOTN
      IF(IA.EQ.IB) GOTO 50
C
C     COMPARE NAME AND NR
C
      IF(IW(IA  ).NE.IW(IB)  ) GOTO 50
      IF(IW(IA+1).NE.IW(IB+1)) GOTO 50
C
C     EQUAL
C
      NW=IW(IB+3)
      CALL UCOPY2(IW(IB+4),IW(IB),NTOTN-4)
      NTOT=NTOT-4
      IW(IA+3)=IW(IA+3)+NW
C
   50 IND=IA+3
      IF(NTOT.EQ.0.AND.ISW.EQ.2) GOTO 66
      IF(NTOT.EQ.0) GOTO 24
   52 NW=IW(IND)
      IF(NW.LE.0) GOTO 54
      IF(IA+NTOT-1-IND-NW) 54,56,60
C     ERROR
   54 CONTINUE
      GOTO 24
C     LAST BANK
   56 IF(ISW.NE.0) GOTO 60
      CALL UCOPY2(IW(IND-3),IW(IA),NW+4)
      NTOT=NW+4
      IB=IA+NTOT
      ISW=0
      GOTO 30
   60 NWR=NW+4
      IF(LUN1.NE.0) CALL WRSQ(LUN1,NWR,IW(IND-3))
      NSE=NSE+1
      IF(NE.NE.0) GOTO 64
      DO 62 I=1,450
   62 IW(INDL+I)=BLANK
   64 JCOL=NE/50
      INDX=INDL+JCOL*3+(NE-JCOL*50)*3*3
      IW(INDX+1)=IW(IND-3)
      IW(INDX+2)=IW(IND-2)
      IW(INDX+3)=IW(IND)
      NE=NE+1
      IF(ISW.EQ.2) GOTO 66
      IF(NE.LT.150) GOTO 70
   66 IF(NPG.GE.NPAGL) GOTO 68
C
C     PRINT TABLE OF CONTENT
C
      NPG=NPG+1
      IF(NUNTB.NE.0) WRITE(NUNTB,103) LUN,NPG
      CALL PRINTA(IW(INDL+1),-3,450)
   68 IF(NE.EQ.150) NE=0
      IF(ISW.EQ.2) GOTO 90
   70 IND=IND+4+NW
      GOTO 52
   90 IF(INDA.EQ.0) GOTO 92
      IF(IUNTP.EQ.0) GOTO 92
      IF(IW(INDA+20).NE.0) GOTO 92
C
C     UPDATE DATE IN MASTER DIRECTORY
C
      LISTE(1)=DIRA
      LISTE(2)=DIRO
      CALL DIDA(-1,LISTE,1)
      CALL WRDA(1,IW(INDA+1),IW(INDA+2))
   92 IZER=IBANK(4H+DIR,-1,2HDL)
      CALL BGAR(IGA)
      IF(NUNTB.NE.0) WRITE(NUNTB,102) LUN,NSE,NERR
      IF(LUN1.NE.0) REWIND LUN1
C
  100 RETURN
  101 FORMAT('0---- DIR-UNIT',I3,0X,'SEQ-UNIT',I3,'   OPTION = ',A4,
     1   '  (BFTDIR START)')
  102 FORMAT('0---- DIR-UNIT',I3,I14,' RECORDS(=BANKS) COPIED,',I4,
     1   ' ILLEGAL RECORDS   (BFTDIR END)')
  103 FORMAT('1---- DIR-UNIT',I3,10X,'PAGE',I3/
     1   11X,3(8X,'NAME',6X,'NUMBER',1X,'NR OF WORDS')/)
  201 CALL BDMPA(47)
  202 CALL BDMPA(48)
  203 CALL BDMPA(49)
      GOTO 100
      END
      SUBROUTINE DIDA(IGOTO,LIST,IL)
      COMMON/ACS/DUMMI(90),NUNTB
C
C     IGOTO =-1   RESERVE DATA SET FOR EXCLUSIVE USE
C     IGOTO = 0   CREATE MASTER DIRECTORY BANK
C     IGOTO = 1   SEARCH FOR NAME,NR IN DIRECTORY RECORDS
C     IGOTO = 2   DELETE NAME,NR IN DIRECTORY RECORD
C     IGOTO = 3   ADD NAME,NR TO DIRECTORY RECORD
C
C     LIST(1) = NAME
C     LIST(2) = NR
C     LIST(3) = NR OF DATA RECORD
C     LIST(4) = NR OF WORDS IN BANK

      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      INTEGER LIST(5,1),IBOS/'BOSS'/,DIRA/'DIRA'/,BINTIM
      JPAS=IPAS
      IPAS=0
      IF(IGOTO.LT.0) GOTO 80
    1 INDA=ILINK(4H+DIR,IUND)
      IF(INDA.EQ.0)  GOTO 10
      IF(IGOTO.GE.0) GOTO 14
      IPRFLG=0
      IF(IW(INDA+20).EQ.0) JPAS=IW(INDA+19)
      GOTO 11
C
C     CREATE MASTER DIRECTORY BANK (FROM DATA SET), IF NOT YET EXISTING
C
   10 INDA=IBANK(4H+DIR,IUND,52)
      IPRFLG=1
      IF(INDA.EQ.0) GOTO 202
   11 CALL RDDA(1,50,IW(INDA+1))
      IW(INDA+ 9)=0
      IW(INDA+10)=0
      IF(IPRFLG.EQ.0) GOTO 15
      IF(NUNTB.NE.0)
     1  WRITE(NUNTB,101) IUND,IW(INDA+6),IW(INDA+7),(IW(INDA+J),J=21,35)
C     READ LAST RECORD, TO CHECK DEFINE FILE STATEMENT
      CALL ERRSET(232,1,1,0,0,232)
      CALL RDDA(IW(INDA+6),1,DUMMY)
C
C     CHECK PASSWORD (IW(INDA+20)=1 MEANS NO CHANGE POSSIBLE)
C
   15 IF(IW(INDA+19).EQ.0)    GOTO 12
      IF(IW(INDA+19).EQ.JPAS) GOTO 12
      IF(JPAS.EQ.IBOS)        GOTO 12
      IW(INDA+19)=0
      IW(INDA+20)=1
      IF(NUNTB.NE.0.AND.IPRFLG.EQ.1) WRITE(NUNTB,102) IUND
      GOTO 14
   12 IW(INDA+20)=0
C
C     CONSISTENCY CHECKS AND BRANCH
C
   14 IF(IW(INDA+2).EQ.DIRA)       GOTO 16
      IF(IW(INDA+2).NE.IW(INDA-3)) GOTO 203
   16 IF(IW(INDA+11).EQ.0) IW(INDA+11)=1610
      NDAREC=IW(INDA+11)
      IF(IGOTO.LE.0) GOTO 100
      IF(IGOTO.EQ.3) GOTO 40
C
C     SEARCH FOR ENTRY IN DIRECTORY RECORDS
C
   20 INDT=0
      NHASH=2+MOD(IABS(LIST(1,1)+LIST(2,1)),IW(INDA+8))
      IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 201
   22 CALL RDDA(NHASH,NDAREC,IW(IA))
      NHASHX=IW(IA+3)
      INDP=IA+4
      K=INDP
      N=IW(K)/4
      IF(N.EQ.0)              GOTO 26
      IF(N.LT.0.OR.N.GT.(NDAREC-10)/4)  GOTO 201
      DO 24 I=1,N
      IF(LIST(1,1).NE.IW(K+1)) GOTO 24
      IF(LIST(2,1).NE.IW(K+2)) GOTO 24
C
C     ENTRY IN DIRECTORY RECORDS FOUND
C
      LIST(3,1)=IW(K+3)
      LIST(4,1)=IW(K+4)
      INDT=K
      IF(IGOTO-1) 100,100,30
   24 K=K+4
   26 NHASH=NHASHX
      IF(NHASH.NE.0) GOTO 22
      GOTO 100
C
C     DELETE NAME,NR FROM DIRECTORY RECORD
C
   30 NWCP=INDP+IW(INDP)-K-4
      IF(NWCP.NE.0) CALL UCOPY2(IW(K+5),IW(K+1),NWCP)
      IW(INDP)=IW(INDP)-4
      IW(IA)  =IW(IA)  -4
      CALL WRDA(NHASH,IW(IA),IW(IA+1))
      GOTO 100
C
C     ADD NAME,NR TO DIRECTORY RECORD
C
   40 NHASHF=0
      NHASHL=0
      IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 202
      I=0
C
C     LOOP FOR IL DIRECTORY ENTRIES
C
   50 I=I+1
      IF(I.GT.IL)         GOTO 70
      NHASH=2+MOD(IABS(LIST(1,I)+LIST(2,I)),IW(INDA+8))
      IF(NHASH.EQ.NHASHF) GOTO 56
      NHASHF=NHASH
   52 IF(NHASHL.EQ.0)     GOTO 54
      CALL WRDA(NHASHL,IW(IA),IW(IA+1))
      NHASHL=0
   54 CALL RDDA(NHASH,NDAREC,IW(IA))
   56 INDP=IA+4
      N=IW(INDP)/4
      IF(N.GE.(NDAREC-10)/4)        GOTO 60
C
C     COPY 4 WORDS INTO DIRECTORY
C
      CALL UCOPY(LIST(1,I),IW(INDP+IW(INDP)+1),4)
      IW(INDP)=IW(INDP)+4
      IW(IA)  =IW(IA)  +4
      NHASHL=NHASH
      GOTO 50
C
C     TRY NEXT DIRECTORY RECORD
C
   60 IF(IW(IA+3).EQ.0) GOTO 62
      NHASH=IW(IA+3)
      GOTO 52
C
C     NEW DIRECTORY RECORD REQUIRED
C     WHAT HAPPENS, IF SPACE ON DATA SET NO SUFFICIENT FOR LOAD
   62 NHASHL=NHASH
      IW(INDA+7)=IW(INDA+7)+1
      NHASH=IW(INDA+7)
C
C     SAVE TWO WORDS FROM DIRECTORY RECORD
C
      NTOT=IW(IA)
      NWDR=IW(IA+4)
C
C     WRITE NEW DIRECTORY RECORD
C
      IW(IA)=4
      IW(IA+4)=0
      CALL WRDA(NHASH,IW(IA),IW(IA+1))
C
C     WRITE EMPTY DATA RECORD
C
      IW(INDA+7)=IW(INDA+7)+1
      IW(IA)=0
      CALL WRDA(NHASH+1,IW(IA),IW(IA+1))
C
C     RESTORE TWO WORDS AND ADD POINTER TO NEXT DIRECTORY RECORD
C
      IW(IA)  =NTOT
      IW(IA+3)=NHASH
      IW(IA+4)=NWDR
      GOTO 52
C
C     FINAL WRITE FOR LAST DIRECTORY RECORD
C
   70 IF(NHASHL.EQ.0) GOTO 100
      CALL WRDA(NHASHL,IW(IA),IW(IA+1))
      GOTO 100
C
C     RESERVE DATA SET FOR EXCLUSIVE USE
C
   80 IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 201
C
C     TRY TO RESERVE DATA SET FOR EXCLUSIVE USE
C
      DO 84 I=1,11
      CALL RDDA(2,50,IW(IA))
      CALL RDDA(1,50,IW(IA))
      ITIME=BINTIM(I)
      IF(IW(IA+ 8).NE.0)        GOTO 82
      IF(IW(IA+ 9).NE.0)        GOTO 82
   81 IW(IA+ 8)=LISTE(1)
      IW(IA+ 9)=LISTE(2)
      IW(IA+11)=ITIME
      CALL WRDA(1,IW(IA),IW(IA+1))
      CALL RDDA(2,50,IW(IA))
      CALL RDDA(1,50,IW(IA))
      IF(IW(IA+ 8).NE.LISTE(1)) GOTO 82
      IF(IW(IA+ 9).NE.LISTE(2)) GOTO 82
      GOTO 1
C
C     DATA SET IN USE, TRY AGAIN
C
   82 JTIME=IW(IA+11)
      IDTIME=ITIME
      IF(IDTIME.LT.JTIME) IDTIME=8640000+IDTIME
      IDTIME=IDTIME-JTIME
      IF(NUNTB.NE.0) WRITE(NUNTB,104) IDTIME
  104 FORMAT(1X,'DATA SET RESERVED, TIME DIFFERENCE IS',I10,'/100 SEC')
C     ASSUME FREE, IF MORE THAN 1 MIN TIME DIFFERENCE
      IF(IABS(IDTIME).GT.6000) GOTO 81
C     WAIT  13 SEC (=500000*26 MIKROSEC)
      CALL DELAY(500000)
   84 CONTINUE
   90 IF(NUNTB.NE.0) WRITE(NUNTB,103) IUND
      GOTO 201
C
C
  100 RETURN
  101 FORMAT('0---- DIR-UNIT',I3,9X,'TOTAL',I6,' RECORDS, USED',
     1   I6,' RECORDS'/'0',38X,'LAST LOAD',17X,'LAST UPDATE',17X,
     2   'LAST UNLOAD'/15X,' DATE',10X,3(2A4,2X,2A4,10X)/
     3   15X,' STORED BANKS',12X,3(I8,20X)/)
  102 FORMAT('0---- DIR-UNIT',I3,9X,'PROTECTED DATA SET, NO BCREDA',
     1   ' OR BDLSDA POSSIBLE'/)
  103 FORMAT('0---- DIR-UNIT',I3,' IN USE, NO CHANGE POSSIBLE - STOP'/)
C
C     ERROR - DATA SET IN USE
C
  201 CALL BDMPA(15)
C
C     INSUFFICIENT SPACE FOR DIRAC OPERATION
C
  202 CALL BDMPA(16)
C
C     ILLEGAL DIRECTORY
C
  203 CALL BDMPA(17)
      GOTO 100
      END
      SUBROUTINE DAFR(IGOTO)
      COMMON/ACS/DUMMI(90),NUNTB
C
C     ACCESS TO DATA RECORD OF DIRECT ACCESS DATA SET
C
C     IGOTO = 1   GET BANK FROM DIRECT ACC. DS
C             2   DELETE BANK FROM DIRECT ACC. DS
C             3   ADD BANK TO DIRECT ACC. DS
C             4   ADD BANK IN PREVIOUS PLACE (SAME LENGTH AS BEFORE)
C
C
C     INTERMEDIATE VARIABLES INDB = INDEX TO DATA IN BANK
C                            NWLB = NR OF DATA WORDS LEFT
C                            NPTR = NR OF DATA RECORD
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      INDB=INDC
      IF(IGOTO.EQ.3) GOTO 50
C
C     ADD, DELETE OR REPLACE
C
      NPTR=LISTE(3)
      NWLB=LISTE(4)
      IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 101
C
C     READ DATA RECORD AND SEARCH FOR NAME,NR
C
   10 CALL RDDA(NPTR,NDAREC,IW(IA))
      INDH=IA+4
      INDL=IA+IW(IA)
      GOTO 14
   12 IF(NPTR.NE.LISTE(3).AND.IGOTO.EQ.2)       GOTO 100
      IF(NPTR.NE.LISTE(3))       GOTO 102
      INDH=INDH+IW(INDH)+4
   14 IF(INDH.GT.INDL.AND.IGOTO.EQ.2)           GOTO 100
      IF(INDH.GT.INDL)           GOTO 102
      IF(IW(INDH-3).NE.LISTE(1)) GOTO 12
      IF(IW(INDH-2).NE.LISTE(2)) GOTO 12
      IF(IGOTO-2) 20,30,40
C
C     COPY BANK FROM DATA RECORD OF DIRECT ACCESS DATA SET
C
   20 CALL UCOPY(IW(INDH+1),IW(INDB+1),IW(INDH))
      INDB=INDB+IW(INDH)
      NWLB=NWLB-IW(INDH)
      IF(NWLB.LE.0) GOTO 100
      NPTR=NPTR+1
      GOTO 10
C
C     DELETE BANK FROM DATA RECORD OF DIRECT ACCESS DATA SET
C
   30 INDS=INDH+IW(INDH)
      NWDS=INDL-INDS
      NWLB=NWLB-IW(INDH)
      IW(IA)=IW(IA)-4-IW(INDH)
      IF(NWDS.GT.0) CALL UCOPY2(IW(INDS+1),IW(INDH-3),NWDS)
C
C     WRITE CHANGED DATA RECORD BACK TO DS
C
   35 CALL WRDA(NPTR,IW(IA),IW(IA+1))
      IF(NWLB.LE.0) GOTO 100
      NPTR=NPTR+1
      GOTO 10
C
C     ADD BANK IN DATA RECORD (SAME PLACE AS BEFORE)
C
   40 CALL UCOPY(IW(INDB+1),IW(INDH+1),IW(INDH))
      INDB=INDB+IW(INDH)
      NWLB=NWLB-IW(INDH)
      GOTO 35
C
C     ADD BANK TO DATA RECORD IN DIRECT ACCESS DATA SET
C
   50 NWLB=IW(INDB)
      NPTR=IW(INDA+7)
      LISTE(3)=0
      LISTE(4)=NWLB
      IA=IBANK(0,0,0)
      IF(IW(IA).LT.NDAREC) GOTO 101
      CALL RDDA(NPTR,NDAREC,IW(IA))
C
C
C
   55 NTOT=IW(IA)
      IF(NTOT.GT.NDAREC-5) GOTO 60
      CALL UCOPY(IW(INDC-3),IW(IA+NTOT+1),4)
      NTOT=NTOT+4
      IW(IA)=NTOT
      NWCP=MIN0(NDAREC-1-NTOT,NWLB)
      IW(IA+NTOT)=NWCP
      CALL UCOPY(IW(INDB+1),IW(IA+NTOT+1),NWCP)
      IF(LISTE(3).EQ.0) LISTE(3)=NPTR
      NTOT=NTOT+NWCP
      IW(IA)=NTOT
      INDB=INDB+NWCP
      NWLB=NWLB-NWCP
      CALL WRDA(NPTR,IW(IA),IW(IA+1))
      IF(NWLB.EQ.0) GOTO 100
C
C     INCREASE RECORD NUMBER AND PREPARE NEW RECORD
C
   60 IW(INDA+7)=IW(INDA+7)+1
      IW(IA)=0
      NPTR=IW(INDA+7)
      GOTO 55
C
C
C
  100 RETURN
C
C     INSUFFICIENT SPACE FOR DIRAC OPERATION
C
  101 CALL BDMPA(101)
C
C     DIRECTORY/DATA RECORD ERROR
C
  102 IF(IGOTO.EQ.2) GOTO 100
      IF(IGOTO.NE.1) GOTO 1002
C
C     DELETE BANK
C
      INDC=IBANK(LISTE(1),LISTE(2),'DL')
      GOTO 100
 1002 CALL BDMPA(102)
      GOTO 100
      END
      SUBROUTINE RDDA(NRC,NTOT,BUFA)
      COMMON/ACS/DUMMI(90),NUNTB
C     BOS SUBPROGRAM  =4.6=
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      INTEGER BUFA(NTOT)
   10 READ(IUND'NRC) BUFA
      GOTO 100
C
      ENTRY WRDA(NRC,NTOT,BUFA)
      IF(NTOT.NE.0) WRITE(IUND'NRC) NTOT,BUFA
      IF(NTOT.EQ.0) WRITE(IUND'NRC) NTOT,NTOT
      GOTO 100
C
      ENTRY RDSQ(IUNTP,NTOT,BUFA,*)
      READ(IUNTP,END=101) NTOT,BUFA
      GOTO 100
C
      ENTRY WRSQ(IUNTP,NTOT,BUFA)
      WRITE(IUNTP) NTOT,BUFA
C
  100 RETURN
  101 RETURN 1
      END
      SUBROUTINE BTCDIR(NAME,NRA,NRB,LUN)
      COMMON/ACS/DUMMI(90),NUNTB
      INTEGER ITAB(10)
      IF(NUNTB.NE.0) WRITE(NUNTB,101) NAME,NRA,NRB,LUN
      IZ=0
      IF(ILINK(NAME,0).NE.0) GOTO 10
      IND=INDDIR(NAME,0,LUN,2HFE)
      IF(IND.EQ.0) GOTO 10
      IND=IBANK(NAME,NR,2HDL)
      IZ=1
   10 NL=-1
      NR=NRA-1
   20 N=0
   30 NB=NRDIR(NAME,NR,LUN,2HGT)
      IF(NB.GT.NRB) GOTO 50
      IF(NB.EQ.0) GOTO 40
   35 NL=NB
      N=N+1
      NR=NB
      ITAB(N)=NB
      IF(N.LT.10) GOTO 30
      IF(NUNTB.NE.0) WRITE(NUNTB,102) ITAB
      GOTO 20
   40 IF(NL.GE.0) GOTO 50
      IF(IZ.EQ.1) GOTO 35
   50 IF(N.EQ.0) GOTO 100
      IF(NUNTB.NE.0) WRITE(NUNTB,102) (ITAB(I),I=1,N)
  100 RETURN
  101 FORMAT('0---- BTCDIR TABLE OF CONTENT OF BANKS WITH NAME ',A4,
     1 ' NR BETWEEN',I10,' AND',I10/
     2 '      ON DIR DATA SET',I3/)
  102 FORMAT(1X,10I10)
      END
      FUNCTION NPDIR(NAME,NR,IUNIT)
      COMMON/ACS/DUMMI(90),NUNTB
C
C
C     FIND ON DIRECT ACCESS DATA SET THE LARGEST NUMBER NN, WHICH IS
C     LESS OR EQUAL TO NR, FOR ALL BANKS WITH NAME.
C
C                 ---- -- -----
C        NN=NPDIR(NAME,NR,IUNIT)
C
      COMMON/BCS/IW(1)
      COMMON/CCS/IUND,INDT,INDC,NPTR,INDA,LISTE(5),IPAS,NDAREC
      NPDIR=0
      IUND=IUNIT
    1 INDD=ILINK('+NPD',IUNIT)
      IF(INDD.EQ.0) GOTO 20
C
C     SEARCH IN TABLE
C
   10 IF(NR.LT.IW(INDD+1)) GOTO 20
      IF(NR.GE.IW(INDD+2)) GOTO 20
      NA=IW(INDD+3)
      IF(NA.EQ.0) GOTO 100
      J=INDD+4
      DO 12 I=1,NA
      IF(NAME.EQ.IW(J)) GOTO 14
   12 J=J+3
      GOTO 100
   14 JA=IW(J+1)
      JB=IW(J+2)
      NPDIR=IW(INDD+JA)
      DO 16 J=JA,JB
      IF(NR.LT.IW(INDD+J)) GOTO 100
   16 NPDIR=IW(INDD+J)
      GOTO 100
C
C     CREATE A NEW LOCAL DIRECTORY BANK
C
C
C     BANK    ('+NPD',IUNIT) CONTENT
C
C       +1     LIMIT OF VALIDITY (LOW)
C        2     LIMIT OF VALIDITY (UP)
C        3     NUMBER OF NAMES
C        4     NAME
C        5     INDEX LOW  (JA)
C        6     INDEX UP   (JB)
C        7     NAME
C        8     INDEX LOW
C        9     INDEX UP
C        ...   ...
C     (JA)     NR     )
C              ...    ) FOR ONE NAME
C     (JB)     NR     )
C
   20 CONTINUE
      CALL RTA
C
C     PREPARE DIRECTORY AND INTERMEDIATE BANKS AND READ DIR RECORDS
C
      CALL DIDA(0,LIST,1)
      INDD=IBANK('+NPD',IUNIT,'DL')
C     RECORD BUFFER
      INDB=IBANK('+NP2',0,NDAREC)
C     SORT BANK
      NAR=1000
      INDR=IBANK('+NP2',1,NAR)
C     NAME/NR DIRECTORY BANK
      NW=3
      INDD=IBANK('+NPD',IUNIT,NW)
      IF(INDB.EQ.0.OR.INDR.EQ.0.OR.INDD.EQ.0) GOTO 200
      NAS=0
      NRUP=0
      NPRIME=IW(INDA+8)
      NRT=IW(INDA+33)
      NRD=0
      JREC=1
   22 JREC=JREC+1
      IF(JREC.GT.NPRIME+1) GOTO 40
      NREC=JREC
   24 IF(NREC.GE.2.AND.NREC.LE.IW(INDA+7)) GOTO 25
      IF(NUNTB.NE.0) WRITE(NUNTB,103) NREC
  103 FORMAT('0ERROR IN NPDIR, RECORD NUMBER IS',I10/)
      GOTO 22
   25 CALL RDDA(NREC,NDAREC,IW(INDB+1))
      NREC=IW(INDB+4)
      K=INDB+2
      N=IW(K+3)/4+1
   26 N=N-1
      K=K+4
      IF(N.GT.0) GOTO 30
      IF(NREC) 24,22,24
C
C     CHECK (NAME,NR) AND STORE
C
   30 NRD=NRD+1
      IF(IW(K+1).LE.0) GOTO 26
      IF(NRUP.EQ.0) GOTO 32
      IF(IW(K+1).GT.NRUP) GOTO 26
C     COMPARE NAME WITH TABLE
   32 NL=(IW(INDD)-1)/3
      IF(NL.EQ.0) GOTO 36
      J=INDD+4
      DO 34 L=1,NL
      IF(IW(J).EQ.IW(K)) GOTO 38
   34 J=J+3
C     NEW NAME
   36 INDD=IBANK('+NPD',IUNIT,NW+3)
      NW=NW+3
      J=INDD+4+3*NL
      IW(J)=IW(K)
      L=NL+1
C     STORE IF INSIDE LIMITS
   38 IF(IW(K+1).GT.NR) GOTO 39
C     POSSIBLE LOWER LIMIT
      IF(IW(K+1).GT.IW(J+1)) IW(J+1)=IW(K+1)
      IF(IW(K+1).LT.IW(J+1)) GOTO 26
   39 IW(INDR+NAS+1)=L
      IW(INDR+NAS+2)=IW(K+1)
      NAS=NAS+2
      IF(NAS.LT.NAR) GOTO 26
C
C     CLEAN TABLE AND SORT
C
   40 INF=2147483647
C     DELETE ENTRIES BELOW LIMITS
      KA=INDR
      IF(NAS.EQ.0) GOTO 50
      DO 42 I=1,NAS,2
      J=INDD+2+3*IW(KA+1)
      IF(IW(KA+2).GE.IW(J)) GOTO 42
      IW(KA+2)=INF
   42 KA=KA+2
C     SORT ARRAY TO INCREASING NR
      CALL SORTAE(IW(INDR+1),2,NAS/2,2,0)
   44 IF(NAS.EQ.0) GOTO 46
      IF(IW(INDR+NAS).NE.INF) GOTO 46
      NAS=NAS-2
      GOTO 44
   46 IF(JREC.GT.NPRIME+1) GOTO 48
      XF=FLOAT(NRD)/FLOAT(NRT+1)
      FAC=0.5*(0.2+0.7*(4.0-XF)*XF/3.0)
      NAF=NAR*FAC
      NAS=MIN0(2*NAF,NAS)
C     IF(NUNTB.NE.0) WRITE(NUNTB,102) NAS,NAR,NRUP,NAF,NRD,NRT,XF,FAC
   48 NRUPC=NRUP
      IF(NRUPC.EQ.0) NRUPC=IW(INDR+NAS)
      NRUPC=MIN0(IW(INDR+NAS),NRUPC)
      IF(NRUPC.GE.NR) NRUP=NRUPC
      IF(NRUP.EQ.0) GOTO 50
   49 IF(NAS.LE.0) GOTO 50
      IF(IW(INDR+NAS).LT.NRUP) GOTO 50
      NAS=NAS-2
      GOTO 49
C
C     FINAL PREPARATION OF LOCAL DIRECTORY BANK
C
   50 IF(JREC.LE.NPRIME+1) GOTO 26
      CALL SORTAA(IW(INDR+1),2,NAS/2,0)
      IF(NAS.LE.0) NAS=0
      NAS2=NAS/2
      IF(NAS.EQ.0) GOTO 58
      J=NAS
      JNR=NAS
   52 L=IW(INDR+J-1)
      IW(INDD+3*L+3)=JNR-NAS2+NW
   54 IW(INDR+JNR)=IW(INDR+J)
      J=J-2
      JNR=JNR-1
      IF(J.LE.0) GOTO 56
      IF(IW(INDR+J-1).EQ.L) GOTO 54
   56 IW(INDD+3*L+2)=JNR+1-NAS2+NW
      IF(J.GT.0) GOTO 52
      CALL UCOPY(IW(INDR+1+NAS2),IW(INDR+1),NAS2)
   58 INDR=IBANK('+NP2',1,NAS2)
      INDB=IBANK('+NP2',0,'DLGC')
      INDD=IBANK('+NPD',IUNIT,NW+NAS2)
      INDR=ILINK('+NP2',1)
      CALL UCOPY(IW(INDR+1),IW(INDD+NW+1),NAS2)
      IW(INDD+1)=NR
      IW(INDD+2)=NRUP
      IF(NRUP.LE.0) IW(INDD+2)=INF
      IW(INDD+3)=NW/3-1
C     IF(NUNTB.NE.0)
C    1  WRITE(NUNTB,101) IUNIT,IW(INDD+1),IW(INDD+2),IW(INDD+3)
      INDR=IBANK('+NP2',1,'DLGC')
      CALL RTE
      GOTO 1
C
C
C
  100 RETURN
C 101 FORMAT('0---- UNIT',I3,' TABLE LIMITS',2I8,I12,' DIFFERENT NAMES')
C 102 FORMAT('0NAS/NAR=',2I10,'   NEW LIMIT IS ',4I10,2G12.4)
  200 INDD=IBANK('+NPD',IUNIT,'DL')
      INDR=IBANK('+NP2',    1,'DL')
      INDB=IBANK('+NP2',    0,'DLGC')
      CALL ABEND
      GOTO 100
      END
      SUBROUTINE SORTAE(A,M,N,KEY,ITYPE)
C
C     SRT04         SORTAE(A,M,N,KEY,ITYPE)
C     -------------------------------------
C
C     SORTAE SORTS AN ARRAY A(M,N) OF N VECTORS, EACH OF LENGTH M,
C     ACCORDING TO THE ELEMENT A(KEY,I) INTO NONDECREASING ORDER,
C     USING THE SHELL ALGORITHM.THE KEY ELEMENT IS ASSUMED TO BE
C     OF TYPE INTEGER (FOR ITYPE=0) OR OF TYPE FLOATING POINT (FOR
C     ITYPE=1).
C
C     USAGE               - - - --- -----
C             CALL SORTAE(A,M,N,KEY,ITYPE)
C                         -
C
C     EXECUTION TIME ON IBM 370/168
C
C     N =  10              T = 220  MIKROSECONDS (ABOUT 30 * COMPARE)
C     N = 100 ... 1000     T = N/15 MILLISECONDS (ROUGHLY LINEAR)
C
C
C
      INTEGER A(M,N),AL1,AL2
      REAL           BL1,BL2
      EQUIVALENCE (AL1,BL1),(AL2,BL2)
      MM=N
   30 MM=MM/2
      IF(MM.EQ.0) GOTO 100
      K=N-MM
      J=0
   40 IF(J.GE.K) GOTO 30
      J=J+1
      L2=J
   50 L1=L2+MM
C
C     COMPARE ELEMENTS L1 AND L2
C     --------------------------
      IF(ITYPE.EQ.1) GOTO 55
C     INTEGER
      IF(A(KEY,L1).GE.A(KEY,L2)) GOTO 40
      GOTO 60
C     FLOATING POINT
   55 AL1=A(KEY,L1)
      AL2=A(KEY,L2)
      IF(BL1.GE.BL2) GOTO 40
C     --------------------------
C
C     EXCHANGE ELEMENTS L1 AND L2
C     ---------------------------
   60 DO 65    I=1,M
      AL1    =A(I,L1)
      A(I,L1)=A(I,L2)
   65 A(I,L2)=AL1
C     ---------------------------
C
      L2=L2-MM
      IF(L2) 40,40,50
C
  100 RETURN
      END
      SUBROUTINE SORTAA(A,M,N,ITYPE)
C
C     SRT05         SORTAA(A,M,N,ITYPE)
C     ---------------------------------
C
C     SORTAA SORTS AN ARRAY A(M,N) OF N VECTORS, EACH OF LENGTH M,
C     ACCORDING TO ALL ELEMENTS IN THE ORDER 1...M, ASSUMED TO BE
C     OF TYPE INTEGER (FOR ITYPE=0) OR OF TYPE FLOATING POINT (FOR
C     ITYPE=1). THE SHELL ALGORITHM IS USED.
C
C     USAGE               - - - -----
C             CALL SORTAE(A,M,N,ITYPE)
C                         -
C
C     EXECUTION TIME ON IBM 370/168
C
C     N =  10              T = 220  MIKROSECONDS (ABOUT 30 * COMPARE)
C     N = 100 ... 1000     T = N/15 MILLISECONDS (ROUGHLY LINEAR)
C
C
C
      INTEGER A(M,N),AL1,AL2
      REAL           BL1,BL2
      EQUIVALENCE (AL1,BL1),(AL2,BL2)
      MM=N
   30 MM=MM/2
      IF(MM.EQ.0) GOTO 100
      K=N-MM
      J=0
   40 IF(J.GE.K) GOTO 30
      J=J+1
      L2=J
   50 L1=L2+MM
C
C     COMPARE ELEMENTS L1 AND L2
C     --------------------------
      IF(ITYPE.EQ.1) GOTO 55
C     INTEGER
      DO 52 KEY=1,M
      IF(A(KEY,L1)-A(KEY,L2)) 60,52,40
   52 CONTINUE
      GOTO 40
C     FLOATING POINT
   55 DO 58 KEY=1,M
      AL1=A(KEY,L1)
      AL2=A(KEY,L2)
      IF(BL1-BL2) 60,58,40
   58 CONTINUE
      GOTO 40
C     --------------------------
C
C     EXCHANGE ELEMENTS L1 AND L2
C     ---------------------------
   60 DO 65    I=1,M
      AL1    =A(I,L1)
      A(I,L1)=A(I,L2)
   65 A(I,L2)=AL1
C     ---------------------------
C
      L2=L2-MM
      IF(L2) 40,40,50
C
  100 RETURN
      END
