C  H.B.A.P.P.    --S80HYC--     MAIN PGM = <HYCS>  LAST UPDATE: 21.10.87
C  SUBROUTINE PACKAGE TO SOLVE LARGE SYSTEMS OF LINEAR EQUATIONS
C  WITH HYPER CHOLESKY METHODS.
C
      SUBROUTINE GETR (IG,IRNU,A,I1,I2)
C
C     READ RECORD IRNU OF FILE IG INTO A FOR DIO PACKAGE
C
      DOUBLE PRECISION A,TR
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      COMMON/OUT/IOU,KKKK
      DIMENSION A(I1),TR(2380)
      DIMENSION IA(3)
      CALL SEARC(IG,IPOS)
      IF(IPOS.EQ.0) CALL DERRO(1,IG,IA)
      K=I1*I2
      IA(1)=IRNU
      IF(IRNU.GT.IFILE(7,IPOS)) CALL DERRO(4,IG,IA)
      IF(K.EQ.IFILE(3,IPOS)) GOTO 10
      IA(2)=K
      IA(3)=IFILE(3,IPOS)
      CALL DERRO(5,IG,IA)
10    CONTINUE
      K1=1+(IRNU-1)*IFILE(5,IPOS)
      K2=K1+IFILE(5,IPOS)-1
      L1=1
      DO 2 M=K1,K2
      L2=L1+IFILE(6,IPOS)-1
      IF(L2.GT.K) L2=K
      READ(IG,REC=M) TR
      IND=0
      DO 3 L=L1,L2
      IND=IND+1
3     A(L)=TR(IND)
2     L1=L2+1
      RETURN
      END
      SUBROUTINE PUTR(IG,IRNU,A,I1,I2)
C
C     WRITE RECORD IRNU FROM A TO FILE IG FOR DIO-PACKAGE
C
      DOUBLE PRECISION A,TR
      DIMENSION A(I1),TR(2380)
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      COMMON/OUT/IOU,KKKK
      DIMENSION IA(3)
      CALL SEARC(IG,IPOS)
      IF(IPOS.EQ.0) CALL DERRO(1,IG,IA)
      K=I1*I2
      IA(1)=IRNU
      IF(IRNU.GT.IFILE(4,IPOS)) CALL DERRO(7,IG,IA)
      IF(IRNU.GT.IFILE(7,IPOS)) IFILE(7,IPOS)=IRNU
      IF(K.EQ.IFILE(3,IPOS)) GOTO 10
      IA(2)=K
      IA(3)=IFILE(3,IPOS)
      CALL DERRO(6,IG,IA)
10    CONTINUE
      K1=1+(IRNU-1)*IFILE(5,IPOS)
      K2=K1+IFILE(5,IPOS)-1
      L1=1
      DO 2 M=K1,K2
      L2=L1+IFILE(6,IPOS)-1
      IF(L2.GT.K) L2=K
      IND=0
      DO 3 L=L1,L2
      IND=IND+1
3     TR(IND)=A(L)
      WRITE(IG,REC=M) TR
2     L1=L2+1
      RETURN
      END
      SUBROUTINE DOPEN(IUNIT,LFN,LRECL,MAXREC,MWREC)
C
C     CREATE FILE TABLE FOR FILE IUNIT FOR DIO-PACKAGE
C
      CHARACTER*8 LFN
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      COMMON/OUT/IOU,KKKK
      COMMON/IBMF/LPRU
      CALL SEARC(IUNIT,IPOS)
      IF(IPOS.NE.0) CALL DERRO(3,IUNIT,NR)
      CALL SEARC(0,IPOS)
      IF(IPOS.EQ.0) CALL DERRO(2,IUNIT,NR)
      IFILE(1,IPOS)=IUNIT
C     IFILE(2,IPOS)=LFN
      IFILE(3,IPOS)=LRECL
      IFILE(5,IPOS)=(LRECL-1)/LPRU+1
      IFILE(7,IPOS)=MWREC
      IFILE(4,IPOS)=MAXREC
      IFILE(6,IPOS)=LPRU
C     OPEN(UNIT=IUNIT,ERR=100,STATUS='SCRATCH',ACCESS='DIRECT',
C    1IOSTAT=IOS,RECL=8*LRECL)
      RETURN
100   WRITE(IOU,200) IUNIT,LFN,IOS
200   FORMAT(/,27H >>>>> OPEN ERROR FOR FILE ,I4,3H,  ,A8,3H,  ,
     110H  IOSTAT= ,I5,6H <<<<<)
      STOP
      END
C
      SUBROUTINE HCHOL(IADM,N,MM1,NN,MB,MR,A,B,C,ID,IR,IGL,IGR)
C
C     HYPERCHOLESKI METHOD FOR SOLUTION OF POSITIVE DEFINIT LINEAR
C     EQUATION SYSTEM
C
      DOUBLE PRECISION A,B,C
      COMMON/OUT/IOU,KKKK
      DIMENSION IADM(N,MM1)
      DIMENSION A(ID,ID),B(ID,ID),C(ID,ID)
      KKKK=0
      DO 21 KZ=1,NN
      K=KZ
      IF(KZ.GT.NN-MR) K=N-NN+KZ
      KS=1
      IF(KZ.GT.NN-MR) KS=MM1-1+KZ-NN
      I1=IXY10(IADM,N,K,KS)
      CALL GETAR(IADM,N,K,KS,A,ID,ID,IGL)
      CALL XY9(A,I1,ID)
      IF(KKKK.NE.0) THEN
        PRINT*,'-- IN <HCHOL>, AFTER <XY9>, K,KS = ',K,KS
        PRINT*,'--    (CHOLESKY PARTITIONING)         A(I,I) ='
        WRITE (6,'(1X,10D12.3)') (A(JJ,JJ),JJ=1,ID)
        CALL MATOUT (1,K,A,ID,ID)
        RETURN
      ENDIF
      M1=NN-KZ+1
      CALL XY11  (A,I1,ID)
      IF(KKKK.NE.0) THEN
        PRINT*,'-- IN <HCHOL>, AFTER <XY11>, K,KS,I1 = ',K,KS,I1
        PRINT*,'--    (INVERSE OF A, AFTER CHOLESKY)  A(I,I) ='
        WRITE (6,'(1X,10D12.3)') (A(JJ,JJ),JJ=1,ID)
        CALL MATOUT (1,K,A,ID,ID)
        RETURN
      ENDIF
      CALL PUTAR(IADM,N,K,KS,A,ID,ID,I1,IGL)
      IF(M1.LT.2) GOTO 11
      DO 1 IZ=2,M1
      IF(IZ.GT.MB.AND.IZ.LE.M1-MR) GOTO 1
      I=IZ
      IF(IZ.GT.M1-MR) I=MM1-1+IZ-M1
      I2=IXY10(IADM,N,K,I)
      IF(I2.EQ.0) GOTO 1
      CALL GETAR(IADM,N,K,I,B,ID,ID,IGL)
      CALL XY5(A,B,C,I1,I2,ID)
      CALL PUTAR(IADM,N,K,I,C,ID,ID,I2,IGL)
1     CONTINUE
11    I0=IXY10(IADM,N,K,MM1)
      IF(I0.EQ.0) GOTO 1161
      CALL GETAR(IADM,N,K,MM1,B,ID,IR,IGR)
      CALL XY5(A,B,C,I1,I0,ID)
      CALL PUTAR(IADM,N,K,MM1,C,ID,IR,I0,IGR)
1161  IF(M1.LT.2) GOTO 21
      M1=M1-1
      IP=0
      DO 22 J=1,M1
      IF(J+1.GT.MB.AND.J.LE.M1-MR) GOTO 22
      KJZ=KZ+J
      KJ=KJZ
      IF(KJZ.GT.NN-MR) KJ=N-NN+KJZ
      KS=1
      IF(KJZ.GT.NN-MR) KS=MM1-1+KJZ-NN
      J1=J+1
      IF(J1.GT.M1-MR+1) J1=MM1-1+J-M1
      I3=IXY10(IADM,N,KJ,KS)
      I4=IXY10(IADM,N,K,J1)
      IF(I4.EQ.0) GOTO 22
      I00=IXY10(IADM,N,KJ,MM1)
      IP=IP+1
      CALL GETAR(IADM,N,K,J1,A,ID,ID,IGL)
      IF(IP.NE.1)GOTO 12
      IF(I0.EQ.0) GOTO 12
      IF(J .NE.1) CALL GETAR(IADM,N,K,MM1,C,ID,IR,IGR)
      CALL XY2(A,C,B,I1,I3,I0,ID)
      IF(I00.NE.0) GOTO 1162
      CALL XY1   (C,I3,I0,ID,ID)
      GOTO 118
1162  CALL GETAR(IADM,N,KJ,MM1,C,ID,IR,IGR)
118   CALL XY6(C,B,I3,I0,ID)
      IF(I00.EQ.0) GOTO 1181
      CALL PUTAR(IADM,N,KJ,MM1,C,ID,IR,I00,IGR)
      GOTO 12
1181  CALL PUTAR(IADM,N,KJ,MM1,C,ID,IR,I0,IGR)
12    N1=M1-J+1
      DO 2 I=1,N1
      IF(IP-1) 13,14,13
13    IIS=N1+1-I
      GOTO 15
14    IIS=I
15    JIS=J+IIS
      IF(JIS.GT.MB.AND.JIS.LE.M1+1-MR) GOTO 2
      KS=1
      IF(KJZ+IIS-1.GT.NN-MR) KS=MM1-2+KJZ+IIS-NN
      II=IIS
      IF(IIS.GT.NN-KJZ+1-MR) II=MM1-2+IIS-NN+KJZ
      JI=JIS
      IF(JIS.GT.M1-MR+1) JI=MM1-2+JIS-M1
      KJZI=KJZ+IIS-1
      IF(KJZI.GT.NN-MR) KJZI=N-NN+KJZI
      I6=IXY10(IADM,N,KJZI,KS)
      I2=IXY10(IADM,N,KJ,II)
      I5=IXY10(IADM,N,K,JI)
      IF(I5.EQ.0) GOTO 2
      IF(IIS.NE.1) CALL GETAR(IADM,N,K,JI,C,ID,ID,IGL)
      IF(IIS-1) 18,19,18
18    CALL XY2    (A,C,B,I1,I3,I6,ID)
      GOTO 17
19    CALL XY8    (A,B,I1,I3,ID)
17    IF(I2.NE.0) GOTO 173
      CALL XY1   (C,I3,I6,ID,ID)
      GOTO 174
173   CALL GETAR(IADM,N,KJ,II,C,ID,ID,IGL)
174   IF(IIS-1) 181,191,181
181   CALL XY6  (C,B,I3,I6,ID)
      GOTO 203
191   CALL XY7    (C,B,I3,ID)
203   CALL PUTAR(IADM,N,KJ,II,C,ID,ID,I6,IGL)
2     CONTINUE
      IF(IP.EQ.1)GOTO 22
      IP=IP-2
      IF(I0.EQ.0) GOTO 22
      CALL GETAR(IADM,N,K,MM1,C,ID,IR,IGR)
      CALL XY2(A,C,B,I1,I3,I0,ID)
      IF(I00.NE.0) GOTO 204
      CALL XY1   (C,I3,I0,ID,ID)
      GOTO 202
204   CALL GETAR(IADM,N,KJ,MM1,C,ID,IR,IGR)
202   CALL XY6(C,B,I3,I0,ID)
      IF(I00.EQ.0) GOTO 2021
      CALL PUTAR(IADM,N,KJ,MM1,C,ID,IR,I00,IGR)
      GOTO 22
2021  CALL PUTAR(IADM,N,KJ,MM1,C,ID,IR,I0,IGR)
22    CONTINUE
21    CONTINUE
      DO 20 K=1,NN
      IS=NN+1-K
      I=IS
      IF(IS.GT.NN-MR) I=N-NN+IS
      I0=IXY10(IADM,N,I,MM1)
      KS=1
      IF(IS.GT.NN-MR) KS=MM1-1+IS-NN
      I1=IXY10(IADM,N,I,KS)
      IF(I0.EQ.0) GOTO 251
      CALL GETAR(IADM,N,I,MM1,B,ID,IR,IGR)
      CALL GETAR(IADM,N,I,KS,A,ID,ID,IGL)
      CALL XY4   (A,B,C,I1,I0,ID)
251   IF(I0.EQ.0) CALL XY1(C,I1,IR,ID,IR)
      CALL PUTAR(IADM,N,I,MM1,C,ID,IR,I0,IGR)
      M1=IS-1
      IF(M1.LT.1) GOTO 20
      DO 4 J=1,M1
      KKZ=IS-J
      IF(J+1.GT.MB.AND.J.LE.NN-KKZ-MR) GOTO 4
      KS=1
      IF(KKZ.GT.NN-MR) KS=MM1-1+KKZ-NN
      KK=KKZ
      IF(KKZ.GT.NN-MR) KK=N-NN+KKZ
      J1=J+1
      IF(J1.GT.NN-KKZ+1-MR) J1=MM1-1+J-NN+KKZ
      I2=IXY10(IADM,N,KK,KS)
      I3=IXY10(IADM,N,KK,J1)
      I03=I0*I3
      I00=IXY10(IADM,N,KK,MM1)
      IF(I03.EQ.0) GOTO 4
      CALL GETAR(IADM,N,KK,J1,A,ID,ID,IGL)
      CALL XY3 (A,C,B,I2,I1,I0,ID)
      IF(I00.NE.0) GOTO 253
      CALL XY1   (A,I2,I0,ID,ID)
      GOTO 27
253   CALL GETAR(IADM,N,KK,MM1,A,ID,IR,IGR)
27    CALL XY6(A,B,I2,I0,ID)
      IF(I00.EQ.0) GOTO 271
      CALL PUTAR(IADM,N,KK,MM1,A,ID,IR,I00,IGR)
      GOTO 4
271   CALL PUTAR(IADM,N,KK,MM1,A,ID,IR,I0,IGR)
4     CONTINUE
20    CONTINUE
      RETURN
      END
      SUBROUTINE XY1(A,I1,I2,ID1,ID2)
C
C     A=0
C
      DOUBLE PRECISION A,D0
      DIMENSION A(ID1,ID2)
      DATA D0/0.0D0/
      DO 1 I=1,I2
      DO 1 K=1,I1
1     A(K,I)=D0
      RETURN
      END
      SUBROUTINE XY2(A,B,C,L,M,N,ID)
C
C     C=AT*B
C     AT=A-TRANSPOSED
C
      DOUBLE PRECISION A,B,C
      DIMENSION A(1),B(1),C(1)
      K=1
      DO 1 I=1,N
      CALL QTRV(A,L,M,B(K),C(K),ID)
1     K=K+ID
      RETURN
      END
      SUBROUTINE XY3(A,B,C,I1,I2,I3,ID)
C
C     C=A*B
C
      DOUBLE PRECISION A,B,C,RS,D0
      DIMENSION A(ID,ID),B(ID,ID),C(ID,ID)
      DATA D0/0.0D0/
      DO 1 I=1,I1
      DO 1 K=1,I3
      RS=D0
      DO 2 J=1,I2
2     RS=RS+A(I,J)*B(J,K)
1     C(I,K)=RS
      RETURN
      END
      SUBROUTINE XY4(R,B,C,I1,I2,ID)
C
C     C=R*B
C     R=UPPER TRIANGULAR MATRIX
C
      DOUBLE PRECISION B,C,R,RS,D0
      DIMENSION R(ID,ID),B(ID,ID),C(ID,ID)
      DATA D0/0.0D0/
      DO 1 I=1,I1
      DO 1 K=1,I2
      RS=D0
      DO 2 J=I,I1
2     RS=RS+R(I,J)*B(J,K)
1     C(I,K)=RS
      RETURN
      END
      SUBROUTINE XY5(R,B,C,I1,I2,ID)
C
C     C=RT*B
C     RT=TRANSPOSED OF R
C     R=UPPER TRIANGULAR MATRIX
C
      DOUBLE PRECISION B,C,R,RS,D0
      DIMENSION R(ID,ID),B(ID,ID),C(ID,ID)
      DATA D0/0.0D0/
      DO 1 I=1,I1
      DO 1 K=1,I2
      RS=D0
      DO 2 J=1,I
2     RS=RS+R(J,I)*B(J,K)
1     C(I,K)=RS
      RETURN
      END
      SUBROUTINE XY6(A,B,I1,I2,ID)
C
C     A=A-B
C
      DOUBLE PRECISION A,B
      DIMENSION A(ID,ID),B(ID,ID)
      DO 1 I=1,I1
      DO 1 K=1,I2
1     A(I,K)=A(I,K)-B(I,K)
      RETURN
      END
      SUBROUTINE XY7(A,B,I1,ID)
C
C     A=A-B
C     A,B=UPPER TRIANGULAR MATRICES
C
      DOUBLE PRECISION A,B
      DIMENSION A(ID,ID),B(ID,ID)
      DO 1 I=1,I1
      DO 1 K=1,I
1     A(K,I)=A(K,I)-B(K,I)
      RETURN
      END
      SUBROUTINE XY8(A,R,M,N,ID)
C
C     R=AT*A
C     AT=A-TRANSPOSED
C     ID=DIMENSIONS OF A,R
C     R=UPPER TRIANGULAR MATRIX
C
      DOUBLE PRECISION A,R
      DIMENSION A(1),R(1)
      K=1
      DO 1 I=1,N
      CALL QTRV(A,M,I,A(K),R(K),ID)
1     K=K+ID
      RETURN
      END
      SUBROUTINE XY9(A,N,ID)
C
C     CHOLESKI PARTITIONING OF A
C
      DOUBLE PRECISION A,RH,RS,D0,D1,DP40
      COMMON/OUT/IOU,KKKK
      DIMENSION A(ID,ID)
      DATA D0/0.0D0/,D1/1.0D0/,DP40/1.D-40/
      DO 7 K=1,N
      IF(K.NE.1) GOTO 2
      RH=A(1,1)
      IF(RH.LE.DP40) CALL ERRHY
      IF(KKKK.NE.0) THEN
        PRINT*,'-- IN <XY9>, ELEMENT A(1,1) = ',A(1,1)
        RETURN
      ENDIF
      RH=DSQRT(RH)
      RH=1.0D0/RH
      DO 1 I=1,N
1     A(1,I)=RH*A(1,I)
      GOTO 6
2     RH=A(K,K)
      IK=K-1
      DO 3 J=1,IK
3     RH=-A(J,K)*A(J,K)+RH
      IF(RH.LE.DP40) CALL ERRHY
      IF(KKKK.NE.0) THEN
        PRINT*,'-- IN <XY9>, ELEMENT ,RH,A(J,K),  J,K= ',RH,A(J,K),J,K
        RETURN
      ENDIF
      RH=DSQRT(RH)
      A(K,K)=RH
      RH=D1/RH
      IK=K+1
      IF(IK.GT.N) RETURN
      DO 5 J=IK,N
      RS=A(K,J)
      IIK=K-1
      DO 4 M=1,IIK
4     RS=-A(M,J)*A(M,K)+RS
5     A(K,J)=RH*RS
6     IK=K+1
      IF(IK.GT.N) RETURN
      DO 7 I=IK,N
7     A(I,K)=D0
      RETURN
      END
      SUBROUTINE XY11(A,N,ID)
C
C     COMPUTE INVERSE OF A
C     A=UPPER TRIANGULAR MATRIX
C
      DOUBLE PRECISION A,RS,D0,D1,DP40
      COMMON/OUT/IOU,KKKK
      DIMENSION A(ID,ID)
      DATA D0/0.0D0/,D1/1.0D0/,DP40/1.0D-30/
      DO 1 I=1,N
      IF(A(I,I).LE.DP40) CALL ERRHY
      IF(KKKK.NE.0) THEN
        PRINT*,'-- IN <XY11>, ELEMENT A(I,I),  I= ',A(I,I),I
        RETURN
      ENDIF
1     A(I,I)=D1/A(I,I)
      N1=N-1
      DO 2 I=1,N1
      I1=I+1
      DO 2 K=I1,N
2     A(K,I)=A(I,K)*A(I,I)
      DO 3 I=1,N1
      NE=N-I
      DO 3 K=1,NE
      IK=I+K
      RS=D0
      DO 4 L=1,I
      KL=K+L
4     RS=RS-A(KL,IK)*A(KL,K)
3     A(K,IK)=RS
      N1=N-1
      DO 5 I=1,N1
      I1=I+1
      DO 5 K=I1,N
5     A(K,I)=D0
      RETURN
      END
      SUBROUTINE QTRV(A,M,N,B,R,ID)
C
C     R=R+B*A
C
      DOUBLE PRECISION A,B,R,D0
      DIMENSION A(ID,ID),R(ID),B(ID)
      DATA D0/0.0D0/
      DO 1 I=1,M
      IF(B(I).NE.D0) GOTO 3
1     CONTINUE
      DO 2 I=1,N
2     R(I)=D0
      RETURN
3     DO 4 K=1,N
      R(K)=D0
      DO 4 L=I,M
4     R(K)=R(K)+B(L)*A(L,K)
      RETURN
      END
      SUBROUTINE ERRHY
C
C     ERROR MESSAGES OF SUBROUTINE HYCHOL
C
      COMMON/OUT/IOU,KKKK
      WRITE(IOU,1002)
1002  FORMAT(/7H >>>>> ,51HREDUCED NORMAL EQUATION MATRIX NOT POSITIVE D
     1EFINIT,16X,5H<<<<<)
      KKKK=-1
      RETURN
      END
      FUNCTION IXY10(IADM,N,I,K)
C
C     COMPUTE RECORD NUMBER OUT OF ADDRESS IADM(I,K)
C
      DIMENSION IADM(N,K)
      I2=IADM(I,K)
      IXY10=I2-I2/1000*1000
      RETURN
      END
      SUBROUTINE GETAR(IADM,N,I,K,A,ID1,ID2,IG)
C
C     READ RECORD WITH ADDRESS IADM(I,K) FROM FILE IG INTO A
C     FOR DIO-PACKAGE
C
      DOUBLE PRECISION A
      DIMENSION A(ID1,ID2),IADM(N,1)
      I1=IADM(I,K)/1000
      CALL GETR(IG,I1,A,ID1,ID2)
      RETURN
      END
      SUBROUTINE PUTAR(IADM,N,I,K,A,ID1,ID2,IS,IG)
C
C     WRITE A WITH ADDRESS IADM(I,K) TO FILE IG FOR DIO-PACKAGE
C
      DOUBLE PRECISION A
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      DIMENSION A(ID1,ID2),IADM(N,1),J(1)
      I1=IADM(I,K)/1000
      CALL SEARC(IG,IPOS)
      IF(IPOS.EQ.0) CALL DERRO(1,IG,J)
      IF(I1.NE.0) GOTO 10
      I1=IFILE(7,IPOS)+1
10    IADM(I,K)=1000*I1+IS
      CALL PUTR(IG,I1,A,ID1,ID2)
      RETURN
      END
      SUBROUTINE VORHY(IADM,N,MM1,LFILE,LFNN)
C
C     OPEN DIRECT ACCESS FILES FOR LINEAR EQUATION SYSTEM
C     FOR DIO-PACKAGE
C
      CHARACTER*8 LFNN
      DIMENSION IADM(N,MM1),LFILE(3,2),LFNN(2)
      DO 1 I=1,N
      DO 1 K=1,MM1
1     IADM(I,K)=0
      DO 2 I=1,2
2     CALL DOPEN(LFILE(1,I),LFNN(I),LFILE(2,I),LFILE(3,I),0)
      RETURN
      END
      SUBROUTINE EVICT(IUNIT)
C
C     CLEAR FILE TABLE FOR FILE IUNIT FOR DIO-PACKAGE
C
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      DIMENSION J(1)
      CALL SEARC(IUNIT,IPOS)
      IF(IPOS.NE.0) GOTO 100
      CALL DERRO(1,IUNIT,J)
100   DO 1 I=1,7
1     IFILE(I,IPOS)=0
      RETURN
      END
      SUBROUTINE DERRO(NERR,IUNIT,ARRAY)
C
C     ERROR MESSAGES OF DIO-PACKAGE
C
C     NERR=1  UNKNOWN FILE NUMBER          NERR,LFN
C     NERR=2  NO SPACE IN /DEFIE/          NERR,LFN
C     NERR=3  FILE ALREADY OPEN            NERR,LFN
C     NERR=4  WRONG RECORD NUMBER (READ)   NERR,LFN,RECNUMB
C     NERR=5  WRONG RECORD LENGTH (READ)   NERR,LFN,RECNUMB,LRECW,LRECC
C     NERR=6  WRONG RECORD LENGTH (WRITE)  NERR,LFN,RECNUMB,LRECW,LRECC
C     NERR=7  NUMBER OF RECORDS TOO SMALL  NERR,LFN,RECNUMB
      COMMON/OUT/IOU,KKKK
      INTEGER ARRAY(3)
      IF(NERR.LT.1.OR.NERR.GT.7) GOTO 100
      GOTO (1,1,1,4,5,5,7,8),NERR
1     WRITE(IOU,1000) NERR,IUNIT
      GOTO 200
4     WRITE(IOU,1000) NERR,IUNIT,ARRAY(1)
      GOTO 200
5     WRITE(IOU,1000) NERR,IUNIT,(ARRAY(I),I=1,3)
      GOTO 200
7     WRITE(IOU,1007) IUNIT,ARRAY(1)
      GOTO 200
100   WRITE(IOU,1000) NERR
200   CONTINUE
      STOP
8     RETURN
1000  FORMAT(/,16H >>>>> DIO-ERROR,5I10)
1007  FORMAT(/,11H >>>>> UNIT,I5,30H -- NUMBER OF RECORDS AT LEAST,I5,
     123X,5H<<<<<)
      END
      SUBROUTINE SEARC(IUNIT,IPOS)
C
C     SEARCH FILE TABLE FOR FILE IUNIT FOR DIO-PACKAGE
C
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      DO 1 IND=1,NOFIL
      IPOS=IND
      IF(IFILE(1,IND).EQ.IUNIT) RETURN
1     CONTINUE
      IPOS=0
      RETURN
      END
      SUBROUTINE DINIT(MOFIL)
C
C     INITIALIZE DIRECT ACCESS FILE TABLE FOR DIO-PACKAGE
C
      COMMON/DEFIE/NOFIL,IFILE(7,2)
      DO 1 I=1,MOFIL
      DO 1 K=1,7
      IFILE(K,I)=0
1     CONTINUE
      NOFIL=MOFIL
      RETURN
C  END SUBROUTINE  DINIT
      END