C     ******************************************************************
C     *                                                                *
C     *                            A M S F                             *
C     *                                                                *
C     *        ARRAY MANAGEMENT SYSTEM  /  FORTRAN VERSION 2.0         *
C     *                                                                *
C     *                                                                *
C     *               (C) 1987, 1988, 1989 BY T.-S. YANG               *
C     *                                                                *
C     *         AERONAUTICAL RESEARCH LABORATORY, AIDC, CSIST.         *
C     *         90008-11-3 TAICHUNG, TAIWAN, REPUBLIC OF CHINA         *
C     *                                                                *
C     ******************************************************************
      BLOCK DATA
      IMPLICIT INTEGER*4(I-N)
      INCLUDE 'AMSCTL.INC'
      DATA NVERSN/2/, LIMIT/55/
      DATA NDATA,LENG,INTL,LENDIR/5,128,4,16/
      DATA NDT/1,2,4/,ISORT/0/,NXTLOC/1/,MCK/0/
      DATA NARY,NOPEN,NREC,NOFF/5*0,5*0,5*2,5*1/
      DATA NTM,NTR/0,0/
      DATA NDB,NTF/11,12,13,14,15,16/
      END

      SUBROUTINE CLOCK( KTM )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0 : READ DATE/TIME VALUES FROM CLOCK AND STORE IT IN KTM
C     (THIS SUBROUTINE IS FOR MICROSOFT FORTRAN 4.0)
      DIMENSION KTM(6)
      INTEGER*2 IT(7)
C ... KTM(I),I=1,6: YEAR, MONTH, DAY, HOUR, MINUTE, SECOND
      CALL GETDAT(IT(1),IT(2),IT(3))
      CALL GETTIM(IT(4),IT(5),IT(6),IT(7))
      DO 10 I=1,6
10    KTM(I) = IT(I)
      RETURN
      END
C
      SUBROUTINE DATES (KTM,DST)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CONVERT DATE/TIME FROM INTEGER TO STRING
      DIMENSION KTM(6),NC(12)
      CHARACTER DST*(*),APM*3,DT(12)*10
      DATA DT/'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY',
     *        'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'/
      DATA NC/8,9,6,6,4,5,5,7,10,8,9,9/
      KT4 = KTM(4)
      APM = ' AM'
      IF (KTM(4).GE.12) APM = ' PM'
      IF (KTM(4).GT.12) KT4 = KT4 - 12
      IM = KTM(2)
      WRITE(DST,10) KT4,KTM(5),KTM(6),APM,DT(IM)(1:NC(IM)),KTM(3),KTM(1)
10    FORMAT(I2.2,':',I2.2,':',I2.2,A,', ',A,I2,', ',I4)
      RETURN
      END
C
      SUBROUTINE INIT
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: INITIALIZE ARRAY MANEGEMENT SYSTEM
      COMMON MAVAIL,IA(30000)
      INCLUDE 'AMSCTL.INC'
      IF (MAVAIL.LT.30000) MAVAIL = 30000
      IDIR   = MAVAIL + 1
      RETURN
      END
C
      SUBROUTINE ERROR(ND,NAME,NV,NCODE)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: PRINT ERROR MESSAGES
      CHARACTER NAME*(*),ERRMSG(21)*50
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      DATA NERROR/21/
      DATA ERRMSG/'ILLEGAL MATRIX DATA TYPE',
     *            'ILLEGAL MATRIX STORAGE MODE',
     *            'NON-POSITIVE ROW DIMENSION',
     *            'NON-POSITIVE COLUMN DIMENSION',
     *            'APPLICABLE ONLY TO SQUARE MATRIX',
     *            'MATRIX ALREADY EXITS',
     *            'ILLEGAL VERSION NUMBER',
     *            'MATRIX NOT FOUND',
     *            'MATRIX IS NOT IN DATABASE FILE',
     *            'NO SUCH VERSION',
     *            'INCORE STORAGE OVERFLOW',
     *            'CAN NOT SAVE IT INTO FILE, NVMAX=0',
     *            'VERSION EXEEDS RESERVED',
     *            'MATRIX IS NOT IN MAIN MEMORY',
     *            'DATABASE NOT OPENED',
     *            'DATABASE NUMBER IS OUT OF RANGE',
     *            'MASTER DATABASE MUST BE OPENED FIRST',
     *            'RENAME TO AN EXISTING ARRAY',
     *            'OUT-OF-CORE VERSIONS ARE REMOVED',
     *            'ARRAYS ARE NOT CONSISTENT',
     *            'TEXT FILE NOT FOUND'/
      WRITE(NTM,10) RTN, ND, DBNAME(ND)
10    FORMAT(' AMS ERROR OCCURS IN SUBROUTINE - ',A/
     *       ' DATABASE ',I2,' : ',A)
      IF (NCODE.GE.1.AND.NCODE.LE.NERROR) THEN
         IF (NV.EQ.0.AND.NAME.NE.' ') THEN
            WRITE(NTM,20) NAME,ERRMSG(NCODE)
         ELSE IF (NV.NE.0.AND.NAME.NE.' ') THEN
            WRITE(NTM,30) NAME,NV,ERRMSG(NCODE)
         ELSE
            WRITE(NTM,40) ERRMSG(NCODE)
         ENDIF
         CALL DBCLOS(1,'SAVE')
      ENDIF
      STOP 'AMS ABORTED.'
20    FORMAT(' ARRAY: ',A,' MESSAGE: ',A)
30    FORMAT(' ARRAY: ',A,', VERSION ',I3,' MESSAGE: ',A)
40    FORMAT(' MESSAGE: ',A)
      END
C
      SUBROUTINE PACK( NAME,INAME )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CONVERT ARRAY NAME INTO 4 INTEGERS
      DIMENSION INAME(1)
      CHARACTER NAME*(*)
      CALL UPCASE(NAME)
      DO 10 I=1,4
10    INAME(I) = ICHAR(' ')
      DO 20 I=1,LEN(NAME)
20    INAME(I) = ICHAR(NAME(I:I))
      RETURN
      END
C
      SUBROUTINE ICLEAR( LA, N )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CLEAR INTEGER ARRAY LA USING LOOP UNROLLING
      DIMENSION LA(1)
      M = N / 10
      L = MOD(N,10)
      DO 10 I = 1, L
10    LA(I) = 0
      I = L + 1
      IF (M.EQ.0) RETURN
      DO 20 J = 1, M
         LA(I)   = 0
         LA(I+1) = 0
         LA(I+2) = 0
         LA(I+3) = 0
         LA(I+4) = 0
         LA(I+5) = 0
         LA(I+6) = 0
         LA(I+7) = 0
         LA(I+8) = 0
         LA(I+9) = 0
         I       = I + 10
20    CONTINUE
      RETURN
      END
C
      SUBROUTINE DUPLIC( LA, LB, N )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: DUPLICATE ARRAY LA TO LB USING LOOP UNROLLING
      DIMENSION LA(1),LB(1)
      M = N / 10
      L = MOD(N,10)
      DO 10 I=1,L
10    LB(I) = LA(I)
      I = L + 1
      IF (M.EQ.0) RETURN
      DO 20 J=1,M
         LB(I)   = LA(I)
         LB(I+1) = LA(I+1)
         LB(I+2) = LA(I+2)
         LB(I+3) = LA(I+3)
         LB(I+4) = LA(I+4)
         LB(I+5) = LA(I+5)
         LB(I+6) = LA(I+6)
         LB(I+7) = LA(I+7)
         LB(I+8) = LA(I+8)
         LB(I+9) = LA(I+9)
         I       = I + 10
20    CONTINUE
      RETURN
      END
C
      SUBROUTINE XFER(IP,NT,NR,NC,MS,NVMAX,NVW,
     *                IREC,IOFF,LOC,NSIZE,NDROP)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: TRANSFER MATRIX ATTRIBUTES
      COMMON  MAVAIL,IA(1)
      NT    = IA(IP+5)
      NR    = IA(IP+6)
      NC    = IA(IP+7)
      MS    = IA(IP+8)
      NVMAX = IA(IP+9)
      NVW   = IA(IP+10)
      IREC  = IA(IP+11)
      IOFF  = IA(IP+12)
      LOC   = IA(IP+13)
      NSIZE = IA(IP+14)
      NDROP = IA(IP+15)
      RETURN
      END
C
      SUBROUTINE KEY(N,NKEY)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CONVERT N-TH ARRAY NAME FROM INTEGER TO STRING
      CHARACTER  NKEY*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      IP = IDIR + (N-1)*LENDIR - 1
      DO 10 I=1,5
10    NKEY(I:I) = CHAR(IA(IP+I))
      RETURN
      END
C
      INTEGER*4 FUNCTION NUMDIR()
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CALCULATE NUMBER OF ARRAYS IN DATABASE
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      NUMDIR = (MAVAIL-IDIR+1)/LENDIR
      RETURN
      END
C
      INTEGER*4 FUNCTION LOOK(ND,NAME)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: FIND THE DIRECTORY ENTRY POINT OF ARRAY 'NAME' BY
C              SEQUENTIAL OR BINARY SEARCH
      CHARACTER   NAME*(*),KEYMID*5,KEYX*5
      DIMENSION   INAME(4)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CALL PACK(NAME,INAME)
      I = 0
      IF (ISORT.EQ.1) THEN
C ... BINARY SEARCH
        KEYX      = '     '
        KEYX(1:1) = CHAR(ND)
        DO 10 J=2,5
10      KEYX(J:J) = CHAR(INAME(J-1))
        LOW = 1
        NHIGH = NUMDIR()
20      IF (LOW.GT.NHIGH.OR.I.NE.0) GOTO 30
           MID = (LOW+NHIGH) / 2
           CALL KEY(MID,KEYMID)
           IF (KEYMID.EQ.KEYX) THEN
              I = MID
           ELSE
              IF (KEYMID.LT.KEYX) THEN
                 LOW   = MID + 1
              ELSE
                 NHIGH = MID - 1
              ENDIF
           ENDIF
        GOTO 20
30      IF (I.GT.0 ) THEN
           LOOK = IDIR + (I-1)*LENDIR
        ELSE
           LOOK = 0
        ENDIF
      ELSE
C ... SEQUENTIAL SEARCH
        IP = IDIR
40      IF (IP.GE.MAVAIL.OR.I.NE.0) GOTO 50
           IF(ND      .EQ.IA(IP)  ) THEN
             IF(INAME(1).EQ.IA(IP+1)) THEN
               IF(INAME(2).EQ.IA(IP+2)) THEN
                 IF(INAME(3).EQ.IA(IP+3)) THEN
                   IF(INAME(4).EQ.IA(IP+4)) THEN
                     I = IP
                   ENDIF
                 ENDIF
               ENDIF
             ENDIF
           ENDIF
           IP = IP + LENDIR
        GOTO 40
50      LOOK = I
      ENDIF
      RETURN
      END
C
      INTEGER*4 FUNCTION MATLEN(NR,NC,NT,MS)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0:  CALCULATE THE MATRIX STORAGE USED
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      IF( MS.EQ.0) THEN
         MATLEN = (NR*NC)*NDT(NT)
      ELSE IF (MS.EQ.1) THEN
         MATLEN = (NR*(NR+1)*NDT(NT)) / 2
      ELSE IF (MS.EQ.2) THEN
         MATLEN = NR*NDT(NT)
      ELSE
         MATLEN = 0
      ENDIF
      RETURN
      END
C
      SUBROUTINE DSKADR( NSIZES,JREC, JOFF, IREC, IOFF )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: FIND THE DISK ADDRESS AFTER ADVANCING NSIZES FROM
C              (JREC,JOFF)
      INCLUDE 'AMSCTL.INC'
      NEOR = LENG - JOFF + 1
      IF (NSIZES .LE. NEOR) THEN
         IOFF = JOFF + NSIZES
         IREC = JREC
         IF ((IOFF-1).EQ.LENG) THEN
            IOFF = 1
            IREC = JREC + 1
         ENDIF
      ELSE
         NS   = NSIZES - NEOR
         IOFF = NS   - INT(NS/LENG)*LENG + 1
         IREC = JREC + INT(NS/LENG) + 1
      ENDIF
      RETURN
      END
C
      SUBROUTINE QFETCH( IP, NV, IAA)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: QUICK DISK FETCH OF MATRIX WITH DIRECTORY ENTRY IP
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      DIMENSION IAA(1)
C     CALCULATE DISK ADDRESS
      ND    = IA(IP)
      NVW   = IA(IP+10)
      NSIZE = IA(IP+14)
      IF (NV.LE.0)    CALL ERROR(ND,'?',NV,7)
      IF (NVW.LT.NV)  CALL ERROR(ND,'?',NV,10)
      CALL DSKADR(NSIZE*(NV-1),IA(IP+11),IA(IP+12),JREC,JOFF)
      READ(NDB(ND),REC=JREC) IBUFF
      JJ = JOFF
      DO 10 II=1,NSIZE
         IAA(II) = IBUFF(JJ)
         IF (JJ.EQ.LENG) THEN
            JREC = JREC + 1
            READ(NDB(ND),REC=JREC) IBUFF
            JJ = 0
         ENDIF
         JJ = JJ + 1
10    CONTINUE
      RETURN
      END
C
      SUBROUTINE QSTORE(IP, NV, IAA)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: QUICK DISK STORE OF MATRIX WITH DIRECTORY ENTRY IP
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      DIMENSION IAA(1)
C ... CALCULATE DISK ADDRESS
      ND    = IA(IP)
      NVW   = IA(IP+10)
      NSIZE = IA(IP+14)
      CALL DSKADR(NSIZE*(NV-1),IA(IP+11),IA(IP+12),JREC,JOFF)
      CALL DSKADR(NSIZE*NV,    IA(IP+11),IA(IP+12),KREC,KOFF)
      READ(NDB(ND),REC=JREC) IBUFF
      JJ = JOFF
      DO 10 II=1,NSIZE
         IBUFF(JJ) = IAA(II)
         IF (JJ.EQ.LENG) THEN
            WRITE(NDB(ND),REC=JREC) IBUFF
            JREC = JREC + 1
            IF (JREC.EQ.KREC)  READ(NDB(ND),REC=JREC) IBUFF
            JJ = 0
         ENDIF
         JJ = JJ + 1
10    CONTINUE
      WRITE(NDB(ND),REC=JREC) IBUFF
      IF (NV.GT.NVW) IA(IP+10) = NV
      RETURN
      END
C
      SUBROUTINE DSORT
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: SORT MATRIX NAMES IN DIRECTORY
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER*5 KEYJ,KEYK
C ... BEGIN SELECTION SORT
      N = NUMDIR()
      IF (N.LE.0) RETURN
      DO 30 I=1,N-1
         K = I
         CALL KEY(K,KEYK)
         DO 10 J=I+1,N
            CALL KEY(J,KEYJ)
            IF (KEYJ.LT.KEYK ) THEN
               K = J
               KEYK = KEYJ
            ENDIF
10       CONTINUE
C ...    SWAP
         IF (I.NE.K) THEN
            IP1 = IDIR + (I-1)*LENDIR
            IP2 = IDIR + (K-1)*LENDIR
            DO 20 J=0,LENDIR-1
               IT        = IA(IP1+J)
               IA(IP1+J) = IA(IP2+J)
               IA(IP2+J) = IT
20          CONTINUE
         ENDIF
30    CONTINUE
      ISORT = 1
      RETURN
      END
C
      SUBROUTINE MATCHK(ND,NAME,NT,MS,NR,NC)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: CHECK MATRIX PARAMETERS
      CHARACTER  NAME*(*)
      IF (NT.LT.0.OR.NT.GT.2) CALL ERROR(ND,NAME,0,1)
      IF (MS.LT.0.OR.MS.GT.2) CALL ERROR(ND,NAME,0,2)
      IF (NR .LE. 0 )         CALL ERROR(ND,NAME,0,3)
      IF (NC .LE. 0 )         CALL ERROR(ND,NAME,0,4)
      IF (MS.EQ.1.OR.MS.EQ.2) THEN
         IF (NR .NE. NC)      CALL ERROR(ND,NAME,0,5)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MEMCHK( MODE )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: SET INCORE MEMORY MONITOR TOGGLE
C              MODE = 'PASSIVE': LET THE USER PROGRAM MAKES DECISION
C                                IF OUT OF MEMORY
C                   = 'ACTIVE' : AMS ABORTED IF OUT OF MEMORY (DEFAULT)
      CHARACTER*(*) MODE
      INCLUDE 'AMSCTL.INC'
      CALL UPCASE(MODE)
      IF (MODE(1:1).EQ.'P') THEN
         MCK = 1
      ELSE
         MCK = 0
      ENDIF
      END
C
      SUBROUTINE DEFINE( ND, NAME, NVMAX, NT, NR, NC, MS, LOC )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: DEFINE A MATRIX
C              NAME  = NAME OF THE MATRIX
C              NVMAX = MAX. VERSION NUMBERS
C              NT    = DATA TYPE: INTEGER, REAL,.OR.COMPLEX
C              NR    = NUMBER OF ROWS
C              NC    = NUMBER OF COLUMNS
C              MS    = STORAGE MODE: GENERAL, SYMMETRIC, DIAGONAL
C              LOC   = INCORE LOCATION  (RETURNED)
      DIMENSION INAME(4)
      CHARACTER NAME*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'DEFINE'
      IF(ND .LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
C ... CHECK MATRIX PROPERTIES
      CALL MATCHK(ND,NAME,NT,MS,NR,NC)
      CALL PACK(NAME,INAME)
      IP = LOOK(ND,NAME)
      IF(IP.GT.0 ) CALL ERROR(ND,NAME,0,6)
C ... EVALUATE STORAGE REQUIREMENT
      NSIZE    = MATLEN(NR,NC,NT,MS)
C ... ASSIGN ARRAY ADDRESS
      LOC      = NXTLOC
C ... SET UP NEW DIRECTORY
      IP = IDIR - LENDIR
      IF (IP.LT.(NXTLOC+NSIZE)) THEN
         IF (MCK.EQ.0) THEN
            CALL ERROR(ND,NAME,0,11)
         ELSE
            LOC = 0
         END IF
      ELSE
         NARY(ND) = NARY(ND) + 1
         IDIR     = IDIR - LENDIR
         NXTLOC   = NXTLOC + NSIZE
      END IF
C ... ALLOCATE DISK SPACE DO MATRIX
      IF (NVMAX.GT.0) THEN
         NSIZES = NSIZE*NVMAX
         CALL DSKADR(NSIZES,NREC(ND),NOFF(ND),IREC,IOFF)
C ...    CLEAR THE DISK SPACE
         READ(NDB(ND),REC=NREC(ND)) IBUFF
         CALL ICLEAR(IBUFF(NOFF(ND)),LENG-NOFF(ND)+1)
         WRITE(NDB(ND),REC=NREC(ND)) IBUFF
         CALL ICLEAR(IBUFF,NOFF(ND))
         DO 10 I=NREC(ND)+1 , IREC
10       WRITE(NDB(ND),REC=I) IBUFF
         IA(IP+11) = NREC(ND)
         IA(IP+12) = NOFF(ND)
         NREC(ND)  = IREC
         NOFF(ND)  = IOFF
      ELSE
         IA(IP+11) = 0
         IA(IP+12) = 0
      ENDIF
C ... STORE MATRIX PROPERTIES IN DIRECTORY
      IA(IP  )  = ND
      IA(IP+1)  = INAME(1)
      IA(IP+2)  = INAME(2)
      IA(IP+3)  = INAME(3)
      IA(IP+4)  = INAME(4)
      IA(IP+5)  = NT
      IA(IP+6)  = NR
      IA(IP+7)  = NC
      IA(IP+8)  = MS
      IA(IP+9)  = NVMAX
      IA(IP+10) = 0
      IA(IP+13) = LOC
      IA(IP+14) = NSIZE
      IA(IP+15) = 0
      ISORT     = 0
      RETURN
      END
C
      SUBROUTINE LOCATE( ND,NAME, NT,NR,NC,MS,LOC )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: LOCATE INCORE MATRIX ADDRESS OF MATRIX 'NAME'.
C     RETURN   LOC=0      IF NOT FOUND,
C              LOC=-NVMAX IF MATRIX 'NAME' IN OUT-OF-CORE DIRECT FILE
C                         USER MUST USE GET('NAME',NV) TO RETRIEVE IT
C                         IF ONLY ONE OUT-OF-CORE VERSION AVAILABLE,
C                         THE VERSION IS AUTO ALLOCATED
C              LOC<>0     LOCATION OF MATRIX 'NAME' STARTED FROM IA(LOC)
      CHARACTER NAME*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'LOCATE'
      IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IP = LOOK(ND,NAME)
      IF (IP.GT.0) THEN
         NT  = IA(IP+5)
         NR  = IA(IP+6)
         NC  = IA(IP+7)
         MS  = IA(IP+8)
         LOC = IA(IP+13)
         IF (LOC .LE. 0 ) LOC = -IA(IP+9)
C ...    CHECK IF ONLY ONE OUT-OF-CORE VERSION EXISTS
C         IF (LOC.EQ.-1) THEN
C ...       ALLOCATE INCORE STORAGE
C            LOC    = NXTLOC
C            NXTLOC = NXTLOC + IA(IP+14)
C            IF (IDIR.LT.NXTLOC) CALL ERROR(ND,NAME,NV,11)
C            IA(IP+13) = LOC
C ...       QUICH FETCH THE MATRIX
C            CALL QFETCH(IP,1,IA(LOC))
C         ENDIF
      ELSE
         LOC = 0
      ENDIF
      RETURN
      END
C
      SUBROUTINE ATTRIB( ND,NAME,NVMAX,NT,NR,NC,MS,LOC,
     *                   NVW,IREC,IOFF,NSIZE,NDROP)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1:  ASK FULL MATRIX ATTRIBUTES IN THE DATABASE ND
      CHARACTER NAME*(*)
      INCLUDE 'AMSCTL.INC'
      RTN = 'ATTRIB'
      LOC    = 0
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IF (NOPEN(ND).EQ.0)         CALL ERROR(ND,NAME,0,15)
      IP  = LOOK(ND,NAME)
      IF (IP.GT.0) THEN
         CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
         IF (LOC.LE.0) LOC = -NVMAX
      ENDIF
      RETURN
      END
C
      SUBROUTINE RENAME( ND,OLDNAM, NEWNAM)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: CHANGE MATRIX NAME FROM 'OLDNAM' TO 'NEWNAM'
      CHARACTER*(*) OLDNAM, NEWNAM
      DIMENSION INAME2(4)
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'RENAME'
      IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,OLDNAM,0,16)
      IP = LOOK(ND,OLDNAM)
      IF (IP.LE.0 ) CALL ERROR(ND,OLDNAM,0,8)
      IP1 = LOOK(ND,NEWNAM)
      IF (IP1.GT.0) CALL ERROR(ND,NEWNAM,0,18)
      CALL PACK(NEWNAM,INAME2)
      DO 10 I=1,4
10    IA(IP+I) = INAME2(I)
      ISORT = 0
      RETURN
      END
C
      SUBROUTINE DELETE( ND, NAME )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: DELETE AN INCORE MATRIX 'NAME' OF DATABASE ND
      CHARACTER NAME*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'DELETE'
      IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IP = LOOK(ND,NAME)
      IF (IP.GT.0.AND.IA(IP+13).GT.0) THEN
C ...    THE MATRIX IS IN MAIN MEMORY GET MATRIX ATTRIBUTES
         NVMAX = IA(IP+9)
         LOC   = IA(IP+13)
         NSIZE = IA(IP+14)
         NXTLOC= NXTLOC - NSIZE
C ...    IS THE MATRIX NOT IN THE LAST POSITION ?
         IF (LOC .LT. NXTLOC) THEN
C ...       COMPACT STORAGE
            CALL DUPLIC( IA(LOC+NSIZE), IA(LOC), NXTLOC-LOC )
         ENDIF
C ...    SET THE NEW LOCATION FOR ALL INCORE MATRICES
         IF (NVMAX.GT.0) THEN
C ...       KEEP THE DIRECTORY, SET LOCATION , ZERO
            IA(IP+13) = 0
         ELSE
C ...       DELETE THE DIRECTORY AND MOVE REMAINDER TO NEW LOCATION
            I = IP - 1
            DO 10 J=IP+LENDIR-1,IDIR+LENDIR-1,-1
               IA(J) = IA(I)
               I = I - 1
10          CONTINUE
            NARY(ND) = NARY(ND) - 1
            IDIR     = IDIR + LENDIR
         ENDIF
C ...    UPDATE MATRIX LOCATION IN DIRECTORY, LOC IN DIR 13
         I = IDIR + 13
         DO 20 J=1,NUMDIR()
            IF (IA(I).GT.LOC ) IA(I) = IA(I) - NSIZE
            I = I + LENDIR
20       CONTINUE
      ENDIF
      RETURN
      END
C
      SUBROUTINE DELALL( ND )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: DELETE ALL INCORE MATRICES OF DATABASE ND
      CHARACTER*4 NAME
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'DELALL'
      IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
C ... RELEASE ALL MAIN MEMORY ALLOCATED BY MATRICES
      IP = MAVAIL - LENDIR + 1
10    IF (IP.LT.IDIR) RETURN
         IF (IA(IP).EQ.ND.AND.IA(IP+13).GT.0) THEN
            DO 20 J=1,4
20          NAME(J:J) = CHAR(IA(IP+J))
            CALL DELETE(ND,NAME)
         ELSE
            IP = IP - LENDIR
         ENDIF
      GOTO 10
      END
C
      SUBROUTINE GET( ND, NAME, NV, LOC )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: GET MATRIX 'NAME' FROM DATABASE ND
      CHARACTER NAME*(*)
      COMMON    MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'GET'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IP = LOOK(ND,NAME)
      IF (IP.EQ.0) CALL ERROR(ND,NAME,0,8)
      CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVMAX.EQ.0) CALL ERROR(ND,NAME,NV,9)
      IF (LOC.EQ.0) THEN
C ...    ALLOCATE INCORE STORAGE
         LOC    = NXTLOC
         NXTLOC = NXTLOC + NSIZE
         IF (IDIR.LT.NXTLOC) CALL ERROR(ND,NAME,NV,11)
         IA(IP+13) = LOC
      ENDIF
C ... QUICH FETCH THE MATRIX
      CALL QFETCH(IP,NV,IA(LOC))
      RETURN
      END
C
      SUBROUTINE SAVE( ND, NAME, NV )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: SAVE MATRIX 'NAME' INTO DATABASE ND
      CHARACTER NAME*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'SAVE'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IF (NV.LE.0) CALL ERROR(ND,NAME,NV,7)
      IP = LOOK(ND,NAME)
      IF (IP.EQ.0) CALL ERROR(ND,NAME,NV,8)
      CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVMAX.EQ.0)  CALL ERROR(ND,NAME,NV,12)
      IF (NVMAX.LT.NV) CALL ERROR(ND,NAME,NV,13)
      IF (LOC.EQ.0)    CALL ERROR(ND,NAME,NV,14)
C ... QUICK STORE THE MATRIX
      CALL QSTORE(IP,NV,IA(LOC))
      RETURN
      END
C
      SUBROUTINE REMOVE( ND, NAME )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: MARK DELETION OF MATRIX 'NAME', THE DIRECTORY WILL BE
C              REMOVED NO MATTER THE MATRIX IS INCORE OR OUT-OF-CORE,
C              BUT THE DISK SPACE DID'NT SHRINK AFTER REMOVED, JUST
C              LEAVE THE FRAGMENT THERE
      CHARACTER NAME*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'REMOVE'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IP  = LOOK(ND,NAME)
      IF (IP.EQ.0 ) CALL ERROR(ND,NAME,0,8)
      LOC = IA(IP+13)
      IF (LOC.GT.0) CALL DELETE(ND,NAME)
      IA(IP+14) = 1
      RETURN
      END
C
      SUBROUTINE COPY( ND1, NAME1, ND2, NAME2 )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: COPY AN INCORE MATRIX 'NAME1' IN DATABASE ND1 TO THE
C              ICORE MATRIX 'NAME2' OF DATABASE ND2.
      CHARACTER*(*) NAME1, NAME2
      COMMON   MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'COPY'
      IF(ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
      IF(ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
      CALL LOCATE(ND1,NAME1,NT1,NR1,NC1,MS1,LOC1)
      IF (LOC1 .LE. 0 ) RETURN
C ... EVALUATE STORAGE REQUIREMENT
      NSIZE = MATLEN(NR1,NC1,NT1,MS1)
      CALL LOCATE(ND2,NAME2,NT2,NR2,NC2,MS2,LOC2)
      IF (LOC2.EQ.0) THEN
C ...    MATRIX 2 IS.NOT.EXIST, CREATE AN INCORE ONE
         NT2 = NT1
         NR2 = NR1
         NC2 = NC1
         MS2 = MS1
         CALL DEFINE(ND2,NAME2,0,NT1,NR1,NC1,MS1,LOC2)
      ELSE IF(LOC2.LT.0) THEN
C ...    MATRIX 2 EXIST, BUT.NOT.AN INCORE ONE
         CALL GET(ND2,NAME2,1,LOC2)
      ENDIF
C ... CHECK COMPATIBILITY
      IF((NT1.NE.NT2).OR.(NR1.NE.NR2).OR.
     *   (NC1.NE.NC2).OR.(MS1.NE.MS2))  RETURN
C ... COPY
      CALL DUPLIC( IA(LOC1), IA(LOC2), NSIZE )
      ISORT = 0
      RETURN
      END
C
      SUBROUTINE FETCH( ND, NAME, NV, IAA)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: COPY AN OUT-OF-CORE MATRIX 'NAME' VERSION NV IN DATABASE
C              ND TO THE INCORE MATRIX 'AA'.
      DIMENSION IAA(1)
      CHARACTER NAME*(*)
      INCLUDE 'AMSCTL.INC'
      RTN = 'FETCH'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IP = LOOK(ND,NAME)
      IF (IP.EQ.0 ) CALL ERROR(ND,NAME,NV,8)
      CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVMAX.EQ.0 ) CALL ERROR(ND,NAME,NV,9)
C ... QUICK FETCH THE MATRIX
      CALL QFETCH(IP,NV,IAA)
      RETURN
      END
C
      SUBROUTINE STORE( ND, NAME, NV, IAA )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: STORE INCORE MATRIX 'AA' INTO MATRIX 'NAME' VERSION NV OF
C              DATABASE ND
      DIMENSION IAA(1)
      CHARACTER NAME*(*)
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'STORE'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IF (NV.LE.0) CALL ERROR(ND,NAME,NV,7)
      IP = LOOK(ND,NAME)
      IF (IP.EQ.0 ) CALL ERROR(ND,NAME,NV,8)
      CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVMAX.EQ.0  ) CALL ERROR(ND,NAME,NV,12)
      IF (NVMAX.LT.NV ) CALL ERROR(ND,NAME,NV,13)
C ... QUICK STORE THE MATRIX
      CALL QSTORE(IP,NV,IAA)
      RETURN
      END
C
      SUBROUTINE MOVE(ND1,NAME1,ND2,NAME2)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: COPY OUT-OF-CORE ARRAY (ND1,NAME1) TO (ND2,NAME2)
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER  NAME1*(*),NAME2*(*)
      RTN = 'MOVE'
      IF (ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
      IF (ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
      IP1 = LOOK(ND1,NAME1)
      IF (IP1.LE.0) CALL ERROR(ND1,NAME1,0,8)
      CALL XFER(IP1,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVMAX.LE.0) CALL ERROR(ND1,NAME1,0,9)
      IF (NDROP.GT.0) CALL ERROR(ND1,NAME1,0,19)
      IP2 = LOOK(ND2,NAME2)
      IF (IP2.LE.0) THEN
         CALL DEFINE(ND2,NAME2,NVMAX,NT,NR,NC,MS,IX)
         IP2 = LOOK(ND2,NAME2)
      ELSE
         CALL XFER(IP2,NT2,NR2,NC2,MS2,NVMAX2,NVW,IREC,IOFF,
     *             LOC,NSIZE,NDROP)
         IF (NT.NE.NT2.OR.NR.NE.NR2.OR.NC.NE.NC2.OR.MS.NE.MS2.OR.
     *       NVMAX.GT.NVMAX2) CALL ERROR(ND1,NAME1,0,20)
         IF (LOC.LE.0) CALL GET(ND2,NAME2,1,IX)
      ENDIF
C ... MOVE IT
      IX = IA(IP2+13)
      IF (IX.LE.0) CALL ERROR(ND2,NAME2,0,11)
      DO 10 I=1,NVMAX
         CALL QFETCH(IP1,I,IA(IX))
         CALL QSTORE(IP2,I,IA(IX))
10    CONTINUE
      RETURN
      END
C
      SUBROUTINE MOVE1V(ND1,NAME1,NV1,ND2,NAME2,NV2)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: COPY ONE VERSION OF OUT-OF-CORE ARRAY (ND1,NAME1,NV1) TO
C              (ND2,NAME2,NV2)
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER  NAME1*(*),NAME2*(*)
      RTN = 'MOVE1V'
      IF (ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
      IF (ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
      IP1 = LOOK(ND1,NAME1)
      IF (IP1.LE.0) CALL ERROR(ND1,NAME1,0,8)
      CALL XFER(IP1,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
      IF (NVW.LT.NV1) CALL ERROR(ND1,NAME1,0,10)
      IF (NDROP.GT.0) CALL ERROR(ND1,NAME1,0,19)
      IP2 = LOOK(ND2,NAME2)
      IF (IP2.LE.0) THEN
         CALL DEFINE(ND2,NAME2,NVMAX,NT,NR,NC,MS,IX)
         IP2 = LOOK(ND2,NAME2)
      ELSE
         CALL XFER(IP2,NT2,NR2,NC2,MS2,NVMAX2,NVW,IREC,IOFF,
     *             LOC,NSIZE,NDROP)
         IF (NT.NE.NT2.OR.NR.NE.NR2.OR.NC.NE.NC2.OR.MS.NE.MS2.OR.
     *       NVMAX.GT.NVMAX2) CALL ERROR(ND1,NAME1,0,20)
         IF (NVMAX2.LT.NV2)  CALL ERROR(ND2,NAME2,NV2,13)
         IF (LOC.LE.0) CALL GET(ND2,NAME2,1,IX)
      ENDIF
C ... MOVE IT
      IX = IA(IP2+13)
      IF (IX.LE.0) CALL ERROR(ND2,NAME2,0,11)
      CALL QFETCH(IP1,NV1,IA(IX))
      CALL QSTORE(IP2,NV2,IA(IX))
      RETURN
      END
C
      SUBROUTINE DBCOPY(ND1,ND2)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: COPY ENTIRE OUT-OF-CORE ARRAYS FROM ND1 TO ND2
      COMMON  MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER  NAME*4
      RTN = 'DBCOPY'
      N   = NUMDIR()
      IP  = IDIR
      DO 30 I=1,N
         ND   = IA(IP)
         IF (ND.NE.ND1) GO TO 15
         NAME = '    '
         DO 10 J=1,4
10       NAME(J:J) = CHAR(IA(IP+J))
         CALL MOVE(ND1,NAME,ND2,NAME)
15       IP   = IP + LENDIR
30    CONTINUE
      RETURN
      END
C
      SUBROUTINE GETDIR(ND,NDIR)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: GET DIRECTORY INFORMATION FROM AN 'OLD' DATABASE
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      IF (ND.EQ.1) THEN
         IDIR = MAVAIL - NARY(ND)*LENDIR + 1
         IS   = MAVAIL
      ELSE
         IS   = IDIR - 1
         IDIR = IDIR - NARY(ND)*LENDIR
      ENDIF
      IF (IDIR.LT.NXTLOC ) CALL ERROR(ND,'OPEN',0,11)
C ... GET DIRECTORY
      NSDIR = NDIR
      II    = IDIR
      JJ    = 1
      READ(NDB(ND),REC=NSDIR) IBUFF
10    IF ( II .GT. IS ) GOTO 20
         IA(II) = IBUFF(JJ)
         IF (JJ.EQ.LENG)THEN
            NSDIR = NSDIR + 1
            READ(NDB(ND),REC=NSDIR) IBUFF
            JJ = 0
         ENDIF
         JJ = JJ + 1
         II = II + 1
      GOTO 10
C ... SET DATABASE INDICATOR
20    II = IDIR
30    IF ( II.GE.IS) RETURN
         IA(II) = ND
         II = II + LENDIR
      GOTO 30
      END

      SUBROUTINE UPCASE(STRING)
      IMPLICIT INTEGER*4(I-N)
      CHARACTER  STRING*(*),CH*1
C ... LEVEL 0: CONVERT LOWER CASE TO UPPER CASE
      DO 10 I=1,LEN(STRING)
      CH = STRING(I:I)
      IF (CH.GE.'a'.AND.CH.LE.'z') THEN
         STRING(I:I) = CHAR( ICHAR(CH) - ICHAR('a') + ICHAR('A') )
      ENDIF
10    CONTINUE
      RETURN
      END
C
      SUBROUTINE DBOPEN( ND, FNAME, STATE )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1:  OPEN DATABASE
      CHARACTER*(*) FNAME, STATE
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'DBOPEN'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL  ERROR(ND,' ',0,16)
      IF (ND.EQ.1 ) CALL INIT
      IF (ND.GT.1) THEN
         IF (NOPEN(1).EQ.0 ) CALL ERROR(ND,' ',0,17)
      ENDIF
      IF(NOPEN(ND).EQ.1) RETURN
C ... CHECK DATABASE FILE STATUS
      CALL UPCASE(STATE)
      CALL UPCASE(FNAME)
      IF (STATE.NE.'NEW'.AND.STATE.NE.'OLD') STATE = 'UNKNOWN'
      IF (STATE.EQ.'UNKNOWN') THEN
         OPEN(NDB(ND),FILE=FNAME,STATUS='OLD',ERR=10)
         STATE = 'OLD'
         CLOSE(NDB(ND))
         GOTO 20
10       STATE = 'NEW'
20       CONTINUE
      ENDIF
      IF (STATE.EQ.'NEW') THEN
         CALL CLOCK(KCTM(1,ND))
         KATM(1,ND) = KCTM(1,ND)
         KATM(2,ND) = KCTM(2,ND)
         KATM(3,ND) = KCTM(3,ND)
         KATM(4,ND) = KCTM(4,ND)
         KATM(5,ND) = KCTM(5,ND)
         KATM(6,ND) = KCTM(6,ND)
         NARY(ND)   = 0
         NREC(ND)   = 2
         NOFF(ND)   = 1
         DO 30 I=1,LENG
30       IBUFF(I) = 0
         OPEN(NDB(ND),FILE=FNAME,ACCESS='DIRECT',RECL=LENG*INTL,
     *                STATUS='UNKNOWN')
         WRITE(NDB(ND),REC=1) IBUFF
         WRITE(NDB(ND),REC=2) IBUFF
      ELSE IF(STATE.EQ.'OLD') THEN
         OPEN(NDB(ND),FILE=FNAME,ACCESS='DIRECT',RECL=LENG*INTL,
     *                STATUS='OLD',IOSTAT=IOS,ERR=40)
40       IF (IOS.NE.0) THEN
            WRITE(NTM,50) FNAME
50          FORMAT(' DATABASE FILE ',A,' NOT FOUND')
            STOP
         ENDIF
         READ(NDB(ND),REC=1) IBUFF
         NSDIR      = IBUFF(1)
         NARY(ND)   = IBUFF(4)
         NREC(ND)   = IBUFF(5)
         NOFF(ND)   = IBUFF(6)
         KCTM(1,ND) = IBUFF(7)
         KCTM(2,ND) = IBUFF(8)
         KCTM(3,ND) = IBUFF(9)
         KCTM(4,ND) = IBUFF(10)
         KCTM(5,ND) = IBUFF(11)
         KCTM(6,ND) = IBUFF(12)
         CALL CLOCK(KATM(1,ND))
         CALL GETDIR(ND,NSDIR)
      ENDIF
      DBNAME(ND) = FNAME
      NOPEN(ND)  = 1
      ISORT      = 0
      RETURN
      END
C
      SUBROUTINE PUTDIR( ND )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 0: SAVE MASTER CONTROL PARAMETERS AND DIRECTORY
C              OF DATABASE ND
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
C ... SAVE MASTER CONTROL PARAMETERS
      CALL CLOCK(KATM(1,ND))
      NSDIR     =  NREC(ND) + 1
      IBUFF(1)  =  NSDIR
      IBUFF(2)  =  LENG
      IBUFF(3)  =  LENDIR
      IBUFF(4)  =  NARY(ND)
      IBUFF(5)  =  NREC(ND)
      IBUFF(6)  =  NOFF(ND)
      IBUFF(7)  =  KCTM(1,ND)
      IBUFF(8)  =  KCTM(2,ND)
      IBUFF(9)  =  KCTM(3,ND)
      IBUFF(10) =  KCTM(4,ND)
      IBUFF(11) =  KCTM(5,ND)
      IBUFF(12) =  KCTM(6,ND)
      IBUFF(13) =  KATM(1,ND)
      IBUFF(14) =  KATM(2,ND)
      IBUFF(15) =  KATM(3,ND)
      IBUFF(16) =  KATM(4,ND)
      IBUFF(17) =  KATM(5,ND)
      IBUFF(18) =  KATM(6,ND)
      WRITE(NDB(ND),REC=1) IBUFF
C ... SAVE DIRECTORY
      N  = NUMDIR()
      II = IDIR
      JJ = 1
      DO 20 I=1,N
         IF (IA(II).EQ.ND) THEN
         DO 10 J=0,LENDIR-1
            IBUFF(JJ) = IA(II+J)
            IF (JJ.EQ.LENG) THEN
               WRITE(NDB(ND),REC=NSDIR) IBUFF
               NSDIR = NSDIR + 1
               JJ = 0
            ENDIF
            JJ = JJ + 1
10       CONTINUE
         ENDIF
         II = II + LENDIR
20    CONTINUE
      WRITE(NDB(ND),REC=NSDIR) IBUFF
      RETURN
      END
C
      SUBROUTINE DBCLOS( ND, STATE )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: CLOSE DATABASE FILE
      CHARACTER STATE*(*)
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      RTN = 'DBCLOS'
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,' ',0,16)
C ... CLEAR INCORE MATRICES
      CALL DELALL(ND)
C ... SAVE DIRECTORY
      CALL PUTDIR(ND)
      NOPEN(ND) = 0
      CALL UPCASE(STATE)
      IF (STATE.EQ.'DELETE' ) THEN
         CLOSE(NDB(ND),STATUS='DELETE')
      ELSE
         CLOSE(NDB(ND),STATUS='KEEP')
      ENDIF
      IF (ND.EQ.1) THEN
         DO 10 I=2,NDATA
         IF (NOPEN(I).EQ.1) THEN
            CALL DELALL(I)
            CALL PUTDIR(I)
            NOPEN(I) = 0
            IF (STATE.EQ.'DELETE' ) THEN
               CLOSE(NDB(I),STATUS='DELETE')
            ELSE
               CLOSE(NDB(I),STATUS='KEEP')
            ENDIF
         ENDIF
10       CONTINUE
         CLOSE(NTM)
         CLOSE(NTR)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MEMORY(NUDIR,NUSED,NFREE)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: INQUIRE MEMORY BANK STATUS
C              NUDIR = MEMORY USED BY DIRECTORY
C              NUSED = MEMORY USED BY INCORE ARRAYS
C              NFREE = FREE MEMORY
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      NUDIR = MAVAIL - IDIR + 1
      NUSED = NXTLOC - 1
      NFREE = IDIR - NXTLOC
      RETURN
      END
C
      SUBROUTINE DIR( LUN )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1: PRINT DIRECTORY TO LOGICAL UNIT NUMBER LUN
      COMMON MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      DIMENSION NDTTM(6)
      CHARACTER TP(0:2)*4, S(0:2)*4, DRP(0:1)*3
      CHARACTER NAME*4, DSTAMP*31, DTTM*31
      DATA TP/'INT ','REAL','CMPX'/, S/'GEN.','SYMM','DIAG'/
      DATA DRP/' NO','YES'/
C
      IF (NOPEN(1).EQ.0) RETURN
      N = NUMDIR()
      CALL CLOCK(NDTTM)
      CALL DATES(NDTTM,DTTM)
      CALL DATES(KATM(1,1),DSTAMP)
      WRITE(LUN,10) '1', NVERSN, DTTM
10    FORMAT(A/' ARRAY MANAGEMENT SYSTEM - FORTRAN VERSION ',I2.2,
     *         ' (C) 1989 BY TZONG-SHUOH YANG'/
     *         ' DIRECTORY LISTING DATE/TIME - ',A/)
      LINE = 5
      DO 30 I=1,NDATA
         IF (NOPEN(I).EQ.1) THEN
            CALL DATES(KCTM(1,I),DSTAMP)
            WRITE(LUN,20) I,DBNAME(I)(1:20),DSTAMP
20          FORMAT(' DATABASE',I3,': ',A,'    CREATED - ',A)
            LINE = LINE + 1
         ENDIF
30    CONTINUE
      IF (N.GT.0) THEN
        WRITE(LUN,40)
40      FORMAT(/' DB NAME TYPE ROWS COLS MODE NVMAX  NVW',
     *          '   LOC.  REC. OFFSET  SIZE DEL'/
     *          ' -- ---- ---- ---- ---- ---- ----- -----',
     *          ' ----- ----- ------ ----- ---')
        IP = IDIR
        DO 75 I=1,N
           ND   = IA(IP)
           NAME = '    '
           DO 60 J=1,4
60         NAME(J:J) = CHAR(IA(IP+J))
           CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
           IF (LINE.GE.LIMIT) THEN
              WRITE(LUN,10) '1',NVERSN,DTTM
              WRITE(LUN,40)
              LINE = 5
           ENDIF
           WRITE(LUN,70) ND,NAME,TP(NT),NR,NC,S(MS),NVMAX,NVW,
     *                   LOC,IREC,IOFF,NSIZE,DRP(NDROP)
70         FORMAT(I3,2A5,2I5,A5,4I6,I7,I6,1X,A)
           IP   = IP + LENDIR
           LINE = LINE + 1
75      CONTINUE
C
80      WRITE(LUN,90) N
90      FORMAT(/' TOTAL OF ',I5,' ARRAYS.')
      END IF
      WRITE(LUN,100) MAVAIL, NXTLOC-1, NARY(1)*LENDIR
100   FORMAT(/' TOTAL MEMORY IN AMS          ',I6,' WORDS.'/
     *        ' MEMORY USED BY ARRAYS        ',I6,' WORDS.'/
     *        ' MEMORY USED BY DIRECTORIES  1',I6,' WORDS.')
      DO 110 I=2,NDATA
110   IF(NOPEN(I).EQ.1) WRITE(LUN,120) I,NARY(I)*LENDIR
120   FORMAT( '                            ',I2,I6,' WORDS.')
      WRITE(LUN,130) IDIR-NXTLOC
130   FORMAT(/' MEMORY AVAILABLE IN AMS      ',I6,' WORDS.'/)
      RETURN
      END
C
      SUBROUTINE DB2TXT( ND, FNAME )
      IMPLICIT INTEGER*4(I-N)
C
C ... LEVEL 1: CONVERT DATABASE ND TO ASCII ARRAY FILE FNAME
C
      COMMON    MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER  NAME*4,FNAME*(*)
      RTN = 'DB2TXT'
      OPEN(NTF,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED')
      REWIND NTF
      N   = NUMDIR()
      IP  = IDIR
      DO 30 I=1,N
         NDX   = IA(IP)
         IF (NDX.NE.ND) GO TO 15
         NAME = '    '
         DO 10 J=1,4
10       NAME(J:J) = CHAR(IA(IP+J))
C
         CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
         IF (NVMAX.LE.0) GO TO 15
C
         WRITE(NTF,100) NAME,NVMAX,NT,NR,NC,MS,NVW
         IF (NVW.EQ.0) GO TO 15
         DO 14 J=1,NVW
            CALL GET(ND,NAME,J,LOC)
            CALL TALK(NTF,IA(LOC),IA(LOC),IA(LOC),NT,NR,NC,MS)
14       CONTINUE
15       IP   = IP + LENDIR
30    CONTINUE
      WRITE(NTF,100) '$$$$'
      CLOSE(NTF)
      RETURN
100   FORMAT(A4,6(1X,I10))
      END

      SUBROUTINE TALK(NTF,IARY,RARY,CARY,NT,NR,NC,MS)
      IMPLICIT INTEGER*4(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION   IARY(1),RARY(1)
      COMPLEX*16  CARY(1)
      IF (MS.EQ.0) THEN
         L = NR*NC
      ELSE IF (MS.EQ.1) THEN
         L = (NR+1)*NR/2
      ELSE
         L = NR
      END IF
      IF (NT.EQ.0) THEN
         DO 10 I=1,L
10       WRITE(NTF,*) IARY(I)
      ELSE IF (NT.EQ.1) THEN
         DO 20 I=1,L
20       WRITE(NTF,*) RARY(I)
      ELSE IF (NT.EQ.2) THEN
         DO 30 I=1,L
30       WRITE(NTF,*) CARY(I)
      ENDIF
      RETURN
      END

      SUBROUTINE TXT2DB( FNAME, ND)
      IMPLICIT INTEGER*4(I-N)
C
C ... LEVEL 1: CONVERT ASCII ARRAY FILE FNAME TO DATABASE ND
C
      COMMON    MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER NAME*4,FNAME*(*)
      RTN = 'TXT2DB'
      OPEN(NTF,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ERR=200)
      REWIND NTF
10    READ(NTF,100,END=99) NAME,NVMAX,NT,NR,NC,MS,NVW
      IF (NAME.EQ.'$$$$') GO TO 99
      CALL DEFINE(ND,NAME,NVMAX,NT,NR,NC,MS,LOC)
      IF (NVW.EQ.0) GO TO 10
      DO 20 J=1,NVW
         CALL HEAR(NTF,IA(LOC),IA(LOC),IA(LOC),NT,NR,NC,MS)
         CALL SAVE(ND,NAME,J)
20    CONTINUE
      GO TO 10
99    CLOSE(NTF)
      RETURN
100   FORMAT(A4,6(1X,I10))
200   CALL ERROR(ND,' ',0,21)
      END

      SUBROUTINE HEAR(NTF,IARY,RARY,CARY,NT,NR,NC,MS)
      IMPLICIT INTEGER*4(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION   IARY(1),RARY(1)
      COMPLEX*16  CARY(1)
      IF (MS.EQ.0) THEN
         L = NR*NC
      ELSE IF (MS.EQ.1) THEN
         L = (NR+1)*NR/2
      ELSE
         L = NR
      END IF
      IF (NT.EQ.0) THEN
         DO 10 I=1,L
10       READ(NTF,*) IARY(I)
      ELSE IF (NT.EQ.1) THEN
         DO 20 I=1,L
20       READ(NTF,*) RARY(I)
      ELSE IF (NT.EQ.2) THEN
         DO 30 I=1,L
30       READ(NTF,*) CARY(I)
      ENDIF
      RETURN
      END
C     ********************************************************************
C     *                                                                  *
C     *                    AMS - OPERATIONAL MODULE                      *
C     *                                                                  *
C     ********************************************************************
      SUBROUTINE MATINP ( ND, NAME )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 2: INTERACTIVE MATRIX INPUT ROUTINE  (FOR ND=1 ONLY)
      COMMON    MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER NAME*(*),DT(0:2)*7,SM(0:2)*9
      DIMENSION IDT(0:2),ISM(0:2)
      DATA DT/'Integer','Real','Complex'/,
     *     SM/'General','Symmetric','Diagonal'/
      DATA IDT/7,4,7/,ISM/7,9,8/
      CALL LOCATE(ND,NAME,NT,NR,NC,MS,LOC)
      RTN = 'MATINP'
      IF (LOC.EQ.0) THEN
         CALL ERROR(ND,NAME,0,8)
      ELSE IF (LOC.LT.0) THEN
         CALL GET(ND,NAME,1,LOC)
      END IF
      WRITE(NTM,10) ND,NAME,NR,NC,DT(NT)(:IDT(NT)),SM(MS)(:ISM(MS))
10    FORMAT(1X,'Enter ',I1,1X,A,', (',I5,' by ',I5,') ',A,' ',
     *       A,' Matrix')
      DO 30 J=1,NC
      IF (MS.EQ.0.OR.MS.EQ.1) THEN
         IS = 1
      ELSE
         IS = J
      ENDIF
      IF (MS.EQ.1.OR.MS.EQ.2) THEN
         IE = J
      ELSE
         IE = NR
      ENDIF
      DO 30 I=IS,IE
      WRITE(NTM,20) ND,NAME,I,J
20    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')='\)
      CALL INP(NTR,IA(LOC),IA(LOC),IA(LOC),NT)
      LOC = LOC + NDT(NT)
30    CONTINUE
      RETURN
      END
C
      SUBROUTINE INP(NTR,I,R,C,NT)
      IMPLICIT INTEGER*4(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      COMPLEX*16 C
      IF (NT.EQ.0) THEN
         READ(NTR,*) I
      ELSE IF (NT.EQ.1) THEN
         READ(NTR,*) R
      ELSE IF (NT.EQ.2) THEN
         READ(NTR,*) C
      ENDIF
      RETURN
      END
C
      SUBROUTINE MATOUT ( ND, NAME )
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 2: INTERACTIVE MATRIX OUTPUT ROUTINE (FOR ND=1 ONLY)
      COMMON    MAVAIL,IA(1)
      INCLUDE 'AMSCTL.INC'
      CHARACTER NAME*(*),DT(0:2)*7,SM(0:2)*9
      DIMENSION IDT(0:2),ISM(0:2)
      DATA DT/'Integer','Real','Complex'/
     *     SM/'General','Symmetric','Diagonal'/
      DATA IDT/7,4,7/,ISM/7,9,8/
      CALL LOCATE(ND,NAME,NT,NR,NC,MS,LOC)
      RTN = 'MATOUT'
      IF (LOC.LE.0) THEN
         WRITE(NTM,10) ND,NAME
10       FORMAT(' MATOUT: ARRAY NOT INCORE OR NOT EXISTS - ',I1,1X,A)
         RETURN
      ENDIF
      WRITE(NTM,20) ND,NAME,NR,NC,DT(NT)(:IDT(NT)),SM(MS)(:ISM(MS))
20    FORMAT(1X,'Output of ',I1,1X,A,', (',I5,' by ',I5,') ',
     *       A,' ',A,' Matrix')
      DO 30 J=1,NC
      IF (MS.EQ.0.OR.MS.EQ.1) THEN
         IS = 1
      ELSE
         IS = J
      ENDIF
      IF (MS.EQ.1.OR.MS.EQ.2) THEN
         IE = J
      ELSE
         IE = NR
      ENDIF
      DO 30 I=IS,IE
      CALL OUT(NTM,ND,NAME,I,J,IA(LOC),IA(LOC),IA(LOC),NT)
      LOC = LOC + NDT(NT)
30    CONTINUE
      RETURN
      END
C
      SUBROUTINE OUT(NTM,ND,NAME,IR,IC,I,R,C,NT)
      IMPLICIT INTEGER*4(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      COMPLEX*16 C
      CHARACTER  NAME*(*)
      IF (NT.EQ.0) THEN
         WRITE(NTM,10)  ND,NAME,IR,IC, I
      ELSE IF (NT.EQ.1) THEN
         WRITE(NTM,20)  ND,NAME,IR,IC, R
      ELSE IF (NT.EQ.2) THEN
         WRITE(NTM,30)  ND,NAME,IR,IC, C
      ENDIF
      RETURN
10    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',I8)
20    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',1PE14.5)
30    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',1PE14.5,'+',1PE14.5,'I')
      END
C
C ... AMS EXTENSION SUBROUTINES
C
      CHARACTER*2 FUNCTION NUMSTR( KI )
      CHARACTER*2 S
      IF (KI.LT.0.OR.KI.GT.99) STOP 'NUMSTR ERROR'
      WRITE(S,'(I2.2)') KI
      NUMSTR = S
      RETURN
      END
C
      FUNCTION INSPCT( ND, NAME, ATTR )
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER*4(I-N)
C ... LEVEL 1:  INSPECT ONE OF THE MATRIX ATTRIBUTES 
      CHARACTER*(*) NAME,ATTR
      INCLUDE 'AMSCTL.INC'
      RTN = 'INSPCT'
      INSPCT = 0
      IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
      IF (NOPEN(ND).EQ.0)         CALL ERROR(ND,NAME,0,15)
      IP  = LOOK(ND,NAME)
      IF (IP.GT.0) THEN
         CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
         IF (ATTR.EQ.'NT') THEN
            INSPCT = NT
         ELSE IF (ATTR.EQ.'NR') THEN
            INSPCT = NR
         ELSE IF (ATTR.EQ.'NC') THEN
            INSPCT = NC
         ELSE IF (ATTR.EQ.'MS') THEN
            INSPCT = MS
         ELSE IF (ATTR.EQ.'NVMAX') THEN
            INSPCT = NVMAX
         ELSE IF (ATTR.EQ.'NVW') THEN
            INSPCT = NVW
         ELSE IF (ATTR.EQ.'IREC') THEN
            INSPCT = IREC
         ELSE IF (ATTR.EQ.'IOFF') THEN
            INSPCT = IOFF
         ELSE IF (ATTR.EQ.'LOC') THEN
            INSPCT = LOC
         ELSE IF (ATTR.EQ.'NSIZE') THEN
            INSPCT = NSIZE
         ELSE IF (ATTR.EQ.'NDROP') THEN
            INSPCT = NDROP
         ELSE 
            INSPCT = 0
         END IF
      ELSE
         STOP 'INSPCT'
      END IF
      RETURN
      END

