C   07/06/96 606071859  MEMBER NAME  NPDIR    (S4)          FORTRAN
      FUNCTION NPDIR(NAME,NR,IUNIT)
C
C     VERSION JULY 82
C
      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.GT.IW(INDD+2)) GOTO 20
C     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) INCLUSIVE
C        2     LIMIT OF VALIDITY (UP)  INCLUSIVE
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
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+34)
      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
C  46 IF(JREC.GT.NPRIME+1) GOTO 48
C     XF=FLOAT(NRD)/FLOAT(NRT+1)
C     FAC=0.5*(0.2+0.7*(4.0-XF)*XF/3.0)
C     NAF=NAR*FAC
C     NAS=MIN0(2*NAF,NAS)
C     IF(NUNTB.NE.0) WRITE(NUNTB,102) NAS,NAR,NRUP,NAF,NRD,NRT,XF,FAC
C  48 NRUPC=NRUP
C     IF(NRUPC.EQ.0) NRUPC=IW(INDR+NAS)
C     NRUPC=MIN0(IW(INDR+NAS),NRUPC)
C     IF(NRUPC.GE.NR) NRUP=NRUPC
C     IF(NRUP.EQ.0) GOTO 50
C  49 IF(NAS.LE.0) GOTO 50
C     IF(IW(INDR+NAS).LT.NRUP) GOTO 50
C     NAS=NAS-2
C     GOTO 49
C
C     FINAL PREPARATION OF LOCAL DIRECTORY BANK
C
C
C     MODIFICATION 5.JULY 82
C
   46 IF(JREC.GT.NPRIME+1) GOTO 50
      XF=FLOAT(NRD)/FLOAT(NRT+1)
      FAC=0.5*(0.2+0.7*(4.0-XF)*XF/3.0)
   47 NAF=NAR*FAC
      NAF=MIN0(2*NAF,NAS)
   48 IF(IW(INDR+NAS).LE.IW(INDR+NAF)) GOTO 49
      NAS=NAS-2
      GOTO 48
   49 NRUP=IW(INDR+NAF)
      IF(NAS.LT.NAR) GOTO 50
      FAC=FAC*0.9
      GOTO 47
   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')
      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
