      PROGRAM HYC
C  H.B.A.P.P.      <P81HYC>                     LAST UPDATE 03.02.88
C
C  SOLUTION OF SYSTEM OF REDUCED NORMAL EQUATIONS BY SUBR. PACKAGE
C  H Y C H O L  ((C) KLEIN).
C
C  INITIALISE, COLLECT ALL PLATE DATA FROM -RSN- FOR INPUT IN HYCHOL
C  SUBROUTINES, SOLVE WHOLE REDUCED SYSTEM OF NORMAL EQUATIONS AND
C  OUTPUT FINAL PLATE CONSTANTS CORRECTIONS.
C
C    DIMTI = TI  AND  DIMTC = TC  NEEDED, EXCEPT  TC = 0 THEN DIMTC = 1
C  WHEN CLOSED ZONE THEN ACTUAL NUMBER OF COLUMNS IN LAST SUBMATRIX
C  SHOULD BE LARGER OR EQUAL TO ACTUAL NUMBER OF ALL OVERLAPPING PLATE
C  CONSTANTS. THIS CAN BE ACHIVED BY CHOOSING IDIM APROPRIATELY.
C
C  +++ LOWER TRIANGEL OF REDUCED SYSTEM IS TAKEN FROM -RSN- AND
C       TRANSPOSED TO SUBMATRICES OF UPPER TRIANGEL FOR HYCHOL  +++++
C  *** NO ELEMENT BELOW DIAGONAL IS SPECIFIED FOR HYCHOL PROGRAM
C       PACKAGE, BECAUSE SYMMETRY IS KNOWN AND APPLIED THERE  ******
C  --- PGM UPGRADED FOR CLOSED ZONES (24H IN RIGHT ASCENSION)
C  --- IHZEI.GE.2 NEEDED
C  --- CHOOSE REGION OF SCRATCH FILES,  FT17F001, FT18F001  BELOW
C
C  INPUT   ON 12: -RSN-  REDUCED SYSTEM OF NORMAL EQ. FROM <P75RN2>
C          ON 13: -B0BC- ACCUMULATED VALUES:  F00, G0
C          ON  5: FNRSN  = FILE NAME OF -RSN-
C                 FNB0BC = FILE NAME OF -B0BC-
C                 FNOUTH = FILE NAME OF -OUTH-
C                 SCALF  = SCALE FACTOR TO PUSH DETERMINANT NEAR 1
C                 IFMOUT = .TRUE. THEN PRINTOUT OF MATRICES AB,B,C
C                 CZ     = 1  IF CLOSED ZONE (LAST IPN OVERLAP FIRST)
C                 CMPBLA = CONNECT.MATR.PLATES, BORDER, ACTUAL LENGTH
C                          (NUMBER OF UNKNOWNS)
C                 TC     = ACTUAL NUMBER OF COMMON PLATE CONSTANTS
C                 IPN1,IPN2 = RANGE OF INTERNAL PLATE NUMBERS TO
C                             PRINTOUT RESULTS (PLATE CONST. CORRECT.)
C                 IPN1,IPN2 = ... NEW RANGE BEHIND PREVIOUS RANGE
C                  ...        (UNTIL END OF UNIT 5)
C
C  SCRATCH ON 17: LEFT  HAND SIDE OF REDUCED SYSTEM, DIRECT ACCESS
C          ON 18: RIGHT HAND SIDE OF REDUCED SYSTEM, DIRECT ACCESS
C                 (17,18 ARE FILES FOR HYCHOL ONLY)
C
C  OUTPUT  ON 20: -OUTH- OUTPUT OF RESULTS FROM HYCHOL: FINAL CORRECT.
C                        TO ALL PLATE CONSTANTS
C          ON 13: -B0BC- OUTPUT RESULTS FOR COMMON PLATE CONSTANTS
C
C  PARAMETER:
C     DIMTI  = NUMBER OF INDIVIDUAL PLATE CONSTANTS OF A PLATE
C     DIMTC  = NUMBER OF COMMON PLATE CONSTANTS
C     DIMIPN = NUMBER OF PLATES IN TOTAL
C     MAXPC  = MAXIMAL NUMBER OF PLAE CONNECTIONS
C   * IDIM   = DIMENSION OF SUBMATIRCES USED BY HCHOL
C   * IHBDI  = NUMBER OF SUBMATRICES IN THE DIAGONAL BAND
C   * IHBRA  = NUMBER OF SUBMATRICES IN THE BORDER
C   * IHBA1  = NUMBER OF COLUMNS IN ADDRESSMATRIX = IHBDI + IHBRA + 1
C   * IHZEI  = NUMBER OF ROWS IN ADDRESSMATRIX
C   * IR     = NUMBER OF RIGHT HAND SIDES (LE.IDIM REQUIRED)
C        *   = HAVE A LOOK AT DOCUMENTS OF HYCHOL PROGRAM PACKAGE

*  --1.--  D E C L A R A T I O N S
      IMPLICIT LOGICAL (A-Z)
      INTEGER DIMTI,DIMTC,DIMIPN,IDIM,IHBDI,IHBRA,IHBA1,IHZEI,IR,MAXPC
      PARAMETER (DIMTI=8,DIMTC=1,DIMIPN=4,IDIM=16,IHBDI=2,
     +           IHBRA=0,IHBA1=3,IHZEI=2,IR=1,MAXPC=10)

*  USED FOR INPUT OF -RSN-:
      LOGICAL LHLCZ, LHL, LHLG2, IFMOUT
      INTEGER I,J,K,N,II,JJ,NFL,NH,LH,IRS,IRS0,JRS,JRS0,IH0,IHL,IH,JH,
     +        JHT,JH0,IAD,JAD,LFL,IPN,IPNC,IPNF,IDIM1,NC,CZ,TC, IFAB,
     +        IPN0,IPN1,IPN2,INN,I0,JLAST,CMPBLA,NTOT,REST,REST0, GOMS
      INTEGER IPNL(MAXPC+1), IFNH(IHBDI), ILENR(IHZEI)
      DOUBLE PRECISION  DUMMY, SCALF
      DOUBLE PRECISION  H(IDIM,IDIM,IHBDI), FL(DIMTI,DIMTI,MAXPC+1),
     +   F(DIMTI,DIMTI),F0(DIMTC,DIMTI),G(DIMTI),F00(DIMTC,DIMTC),
     +   G0(DIMTC), SP(DIMTI), AB(IDIM,IDIM), AR(IDIM,IR),
     +   A(IDIM,IDIM), B(IDIM,IDIM), C(IDIM,IDIM)
      CHARACTER*25 FNRSN, FNB0BC, FNOUTH

*  USED FOR HYCHOL SUBROUTINES:
      INTEGER IOU,KKKK,NOFIL,IGL,IGR,NTRSZ,LPRU, IHBDJ
      INTEGER IADM(IHZEI,IHBA1),LFILE(3,2)
      INTEGER IFILE(7,2), IXY10
*  IFILE IS USED IN A COMMON BLOCK, IXY10 IS A FUNCTION
      CHARACTER*8 LFNAM(2)

      COMMON /OUT/   IOU,KKKK
      COMMON /IBMF/  LPRU
      COMMON /DEFIE/ NOFIL,IFILE

*  --2.--  P R E P A R A T I O N
      PRINT*,'- - -  H. B. A. P. P.    < P 8 1 H Y C >  '
     +      ,'  SOLUTION OF REDUCED NORMAL EQUATION WITH HYCHOL SUBR.'
      PRINT*,' '
      PRINT*,'P A R A M E T E R :  DIMTI, DIMTC, DIMIPN, MAXPC  = ',
     +                             DIMTI, DIMTC, DIMIPN, MAXPC
      PRINT*,'                     IDIM, IHBA1, IHBDI, IHBRA, IHZEI,',
     +       ' IR = ', IDIM, IHBA1, IHBDI, IHBRA, IHZEI, IR
      PRINT*,' '
      READ*,  FNRSN
      PRINT*,'INPUT  FILE   FNRSN  = ',FNRSN
      READ*,  FNB0BC
      PRINT*,'INPUT  FILE   FNB0BC = ',FNB0BC
      READ*,  FNOUTH
      PRINT*,'OUTPUT FILE   FNOUTH = ',FNOUTH

      OPEN (12,FILE=FNRSN ,FORM='UNFORMATTED')
      OPEN (13,FILE=FNB0BC,FORM='UNFORMATTED')
      OPEN (17,ACCESS='DIRECT',RECL=19042)
      OPEN (18,ACCESS='DIRECT',RECL=19042)
      OPEN (20,FILE=FNOUTH,FORM='UNFORMATTED')

      DO 21  I=1,4
21      READ (13) DUMMY
      READ (13) F00
      READ (13) G0
      PRINT*,' '
      PRINT*,'PRINTOUT TO CHECK:'
      PRINT*,'F00 = ',F00
      PRINT*,'G0  = ',G0
      PRINT*,' '
      READ*, SCALF
      PRINT*,'SCALE FACTOR     SCALF = ',SCALF

      DO 22 I=1,DIMTC
        G0(I) = G0(I) * SCALF
        DO 22 J=1,DIMTC
22        F00(I,J) = F00(I,J) * SCALF
      PRINT*,' '
      PRINT*,'SCALED  F00 = ',F00
      PRINT*,'SCALED  G0  = ',G0

      READ*, IFMOUT
      IF (IFMOUT) THEN
        PRINT*,'PRINTOUT OF MATRICES  AB,B,C  (1 ELEMENT = 1 CHARACTER)'
      ELSE
        PRINT*,'N O   PRINTOUT OF MATRICES  AB,B,C'
      ENDIF

      READ*, CZ
      IF (CZ.EQ.0) THEN
        PRINT*,'CZ = 0  *** NO CLOSED ZONE ***'
      ELSEIF (CZ.EQ.1) THEN
        PRINT*,'CZ = 1  *** CLOSED ZONE ***, OVERLAP FIRST/LAST PLATES'
      ELSE
        PRINT*,'CZ = ',CZ,' INVALID, USE CZ = 0 OR 1  --- S T O P ---'
        STOP
      ENDIF
      IF (IHZEI.LT.2) THEN
        PRINT*,'IHZEI IS TOO SMALL, USE IHZEI.GE.2   +++STOP+++ '
        STOP
      ENDIF
      IF (IHBRA.NE.1.AND.IHBRA.NE.0) THEN
          PRINT*,'IHBRA = 0 OR 1  REQUIRED    +++STOP+++'
          STOP
      ENDIF
      IHBDJ = 2
      IF (IHZEI.EQ.2.AND.IHBRA.EQ.1)  IHBDJ = 1
      IF (IHBDI.NE.IHBDJ) THEN
          PRINT*,'IHBDI = ', IHBDJ,' REQUIRED   +++STOP+++'
          STOP
      ENDIF
      PRINT*,' '
      READ*, CMPBLA
      PRINT*,'ACTUAL LENGTH OF BORDER OF CONNECT.MAT. CMPBLA = ',CMPBLA
      READ*, TC
      PRINT*,'ACTUAL NUMBER OF COMMON PLATE CONSTANTS     TC = ',TC

      LHL   = .FALSE.
      LHLCZ = .FALSE.
      LHLG2 = .FALSE.

      LFL = 0
      IH0 = 0
      IHL = IDIM
      LH  = 1
      IDIM1 = IDIM + 1
      NTOT  = DIMIPN * DIMTI
      JLAST = NTOT - (NTOT/IDIM) * IDIM
      IF (JLAST.EQ.0)  JLAST = IDIM
      PRINT*,' '
      PRINT*,'ACTUAL NUMBER OF COLUMNS IN LAST SUBMATRIX (INDIVID. ',
     +       'PLATE CONSTANTS)     JLAST = ', JLAST
      REST = JLAST + TC
      IF (CZ.NE.1)  REST = TC
      REST0= REST - TC
      PRINT*,'ACTUAL NUMBER OF COLUMNS IN BORDER          REST  = ',REST
      PRINT*,'NUMBER OF UNKNOWNS IN BORDER EXEPT COMMON PLATE ',
     +       'CONSTANTS    REST0 = ', REST0
      PRINT*,' '
      IF (REST.GT.IDIM) THEN
        PRINT*,'REST IS LARGER THAN  IDIM   -- INVALID --  +++STOP+++'
        STOP
      ENDIF
      IF (CZ.EQ.1.AND.REST0.LT.CMPBLA)  THEN
        PRINT*,'REST IS TOO SMALL, MORE THAN ONE HYPERLINE IS NEEDED',
     +         ' HERE TO COVER OVERLAP OF LAST PLATES WITH FIRST'
        PRINT*,'+++STOP+++'
        STOP
      ENDIF

      IFAB = 0
      DO 23  NH=1,IHBDI
        IFNH (NH) = 0
        DO 23 I=1,IDIM
        DO 23 J=1,IDIM
          H (I,J,NH) = 0.0 D0
23    CONTINUE

      DO 24  I = 1,IDIM
      DO 24  J = 1,IDIM
        AB (I,J) = 0.0D0
        A  (I,J) = 0.0D0
        B  (I,J) = 0.0D0
24      C  (I,J) = 0.0D0
      DO 25  I = 1,IDIM
      DO 25  J = 1,IR
25      AR (I,J) = 0.0D0

*  --3.--  I N I T I A L I S E    H Y C H O L
*  IOU= LOG.FILENUMBER FOR ERROR MESSAGES,
*  IGL, IGR = LOG.FILENUMBER FOR LEFT/RIGHT HAND SIDE (SCRATCH,INTERNAL)
      IOU  = 6
      IGL  = 17
      IGR  = 18
*  TRACK SIZE OF DISC IN BYTES (IBM FORMAT)
      NTRSZ= 19040
      LPRU = NTRSZ/8

*  INITIALIZATION OF FILE TABLE FOR FILES (I.E. HYCHOL ONLY 2 FILES)
      PRINT*,'NOW CALL DINIT'
      CALL DINIT(2)

*  INITIALIZATION FOR OPEN STATEMENTS, RIGHT AND LEFT HAND SIDE:
*  FILENAME, LOG.FILENUMB.,RECORD LENGTH, MAX.NUMB. OF RECORDS
      LFNAM (1)   = 'LE.SCR'
      LFILE (1,1) = IGL
      LFILE (2,1) = IDIM*IDIM
      LFILE (3,1) = IHZEI*(IHBA1-1)
      LFNAM (2)   = 'RI.SCR'
      LFILE (1,2) = IGR
      LFILE (2,2) = IDIM
      LFILE (3,2) = IHZEI

      PRINT*,'NOW CALL VORHY'
      CALL VORHY(IADM,IHZEI,IHBA1,LFILE,LFNAM)
      PRINT*,' '

*  --4.--  L O O P    H Y P E R L I N E S    F L
      CALL CLOCKM (GOMS)
      PRINT*,'--- START LOOP INPUT          CPU-TIME= ',GOMS,' MILLISEC'
4     CONTINUE
        DO 41 I=1,DIMTI
        DO 41 J=1,DIMTI
        DO 41 K=1,MAXPC+1
41        FL (I,J,K) = 0.0 D0

        READ (12,END=900)  IPN,NC,F0,G
        LFL = LFL + 1
        DO 42  I=1,DIMTI
          G(I) = G(I) * SCALF
          DO 42  J=1,DIMTC
42          F0(J,I) = F0(J,I) * SCALF

*  --5.--  L O O P   R E A D    F  MATRICES
        DO  5  NFL = 1,NC+1
          READ (12,END=997) IPNF,IPNC,F
          IF (IPNF.NE.IPN) THEN
            PRINT*,'IPN, IPNF, IPNC, NC = ',IPN,IPNF,IPNC,NC
            PRINT*,'NO MATCH OF IPN, IPNF  --- S T O P ---'
            STOP
          ENDIF

          DO 51  I=1,DIMTI
          DO 51  J=1,DIMTI
51          FL (I,J,NFL) = F (I,J) * SCALF
          IPNL (NFL) = IPNC
5       CONTINUE

        IRS0 = (IPN-1) * DIMTI

*  --6.--  L O O P    L I N E S   I
        DO 6  I = 1, DIMTI
          IRS = IRS0 + I

          IF (IRS.GT.IHL) THEN

*  --7.--  O U T P U T   H,   N E W   HYPERLINE  H
            DO 7  NH = 1, IHBDI
              IF (IFNH(NH).EQ.1) THEN
                DO 71  II=1,IDIM
                DO 71  JJ=1,IDIM
71                A (II,JJ) = H (JJ,II,NH)
                IAD = LH - NH + 1
                JAD = NH
                IF (JAD.EQ.1) CALL MATOUT (0,IAD,A,IDIM,IDIM)
                CALL  PUTAR (IADM,IHZEI,IAD,JAD,A,IDIM,IDIM,IDIM,IGL)
              ENDIF
7           CONTINUE

            IF (CZ.EQ.1.AND.LH.EQ.1) THEN
*             USE ARRAY C FOR COMMON PLATE CONSTANTS OF CLOSED ZONE
*             OF LINE  LH = 1.  WAIT FOR PLATE CONNECTIONS IN BORDER
              DO 72 II = 1,IDIM
              DO 72 JJ = REST0+1, REST0+TC
72              C(II,JJ) = AB(II,JJ)
            ELSEIF (CZ.EQ.1.AND.LH.EQ.IHZEI-1) THEN
*             USE ARRAY B FOR COMMON PLATE CONSTANTS OF CLOSED ZONE
*             OF LINE  LH = IHZEI-1. WAIT FOR PLATE CONNECT. IN BORDER
              DO 73 II = 1,IDIM
              DO 73 JJ = REST0+1, REST0+TC
73              B(II,JJ) = AB(II,JJ)
            ELSEIF (REST.NE.0.AND.IFAB.EQ.1) THEN
*             TRANSFERE BORDER(= COMMON PLATE CONSTANTS ONLY)
              CALL  PUTAR (IADM,IHZEI,LH ,IHBA1-1,AB,IDIM,IDIM,REST,IGL)
            ENDIF
            CALL    PUTAR (IADM,IHZEI,LH ,IHBA1,  AR,IDIM,  IR,  IR,IGR)

            IH0 = IHL
            IHL = IH0 + IDIM
            LH  = LH + 1
            IFAB = 0
            IF (LH.EQ.IHZEI.AND.IHBRA.EQ.1)  LHL = .TRUE.
            IF (LHL.AND.CZ.EQ.1)           LHLCZ = .TRUE.
            IF (LHL.AND.IHZEI.GT.2)        LHLG2 = .TRUE.
            DO 74  NH = 1,IHBDI
              IFNH (NH) = 0
              DO 74 II=1,IDIM
              DO 74 JJ=1,IDIM
74              H (II,JJ,NH) = 0.0 D0
            DO 76 II=1,IDIM
              DO 75 JJ=1,IDIM
75              AB (II,JJ) = 0.0 D0
              DO 76 JJ=1,IR
76              AR (II,JJ) = 0.0 D0
          ENDIF
* - - - - - - - - (IRS.GT.IHL) -- OUTPUT  HYPERLINE  H - - - - - - -

          JH0  = IH0 + IDIM + 1
          IH   = IRS - IH0

*  --8.--  L O O P   TRANSFERE   F  MATRICES  INTO  HYPERLINE  H
          DO  8  N = 1, NC + 1
            IPNC = IPNL (N)
            JRS0 = (IPNC-1) * DIMTI

            DO 8  J=1,DIMTI
              JRS = JRS0 + J
              IF (JRS.GT.IRS) GOTO 8
              JHT = JH0  - JRS
              NH  = 1 + (JHT-1) / IDIM
              JH  = JHT - (NH-1) * IDIM
              JH  = IDIM1 - JH

              IF (LHLCZ.AND.NH.EQ.1) THEN
*               INTO BORDER MATRIX OF LAST HYPERLINE
                IFAB = 1
                AB (JH,IH) = FL (I,J,N)
              ELSEIF (LHLG2.AND.NH.EQ.2) THEN
*               CONNECTIONS OF LAST PLATES WITH ADJACENT PLATES BEFORE
                B  (JH,IH) = FL (I,J,N)
              ELSEIF (LHLCZ.AND.NH.EQ.IHZEI) THEN
*               CONNECTIONS OF LAST PLATES WITH FIRST PLATES
                C  (JH,IH) = FL (I,J,N)
              ELSE
                IFNH (NH) = 1
                H (IH,JH,NH) = FL (I,J,N)
              ENDIF
8         CONTINUE

          DO 81  J=1,TC
            IFAB = 1
            JJ = REST0 + J
81          AB (IH,JJ) = F0 (J,I)
          AR (IH,1) = G (I)

6       CONTINUE
* - - - - - - - - - - - - - - - - - -  READ IN NEW HYPERLINE  FL ---
      GOTO  4

*  --9.--  L A S T    L I N E   OF HYPERMATRIX
900   CONTINUE
      CALL CLOCKM (GOMS)
      PRINT*,'--- LAST LINE OF HYPERMATRIX, CPU-TIME= ',GOMS,' MILLISEC'
      PRINT*,' '
      PRINT*,'+ + + +  LAST  HYPERLINE  FL  READ IN  + + + +'
      PRINT*,'LFL = ',LFL,' LH = ',LH,'  IH0,IHL,IH = ',IH0,IHL,IH,
     +       '  IPN, NC = ',IPN,NC

      IF (LHLCZ) THEN
*       LAST HYPERLINE IN CASE OF CLOSED ZONE
*       INPUT  F00, G0 INTO BORDER  AB  AND RIGHT HAND SIDE  AR:
        DO 91 I=1,TC
          II = REST0 + I
          AR (II,1) = G0 (I)
          DO 91 J=1,TC
            JJ = REST0 + J
91          AB (II,JJ) = F00 (J,I)

        IF (IFMOUT) THEN
          PRINT*,'MATOUT: ARRAY  AB: AT POSITION = ',IHZEI,IHBA1-1
          CALL MATOUT (1,IHZEI,AB,JLAST,IDIM)
          PRINT*,'MATOUT: ARRAY  C : AT POSITION =  1 ',IHBA1-1
          CALL MATOUT (1,    1,C,JLAST,IDIM)
          PRINT*,'MATOUT: ARRAY  B : AT POSITION = ',IHZEI-1,IHBA1-1
          CALL MATOUT (1,IHZEI-1,B,JLAST,IDIM)
        ENDIF
        CALL  PUTAR (IADM,IHZEI,IHZEI  ,IHBA1  ,AR,IDIM,  IR,  IR,IGR)
        CALL  PUTAR (IADM,IHZEI,IHZEI  ,IHBA1-1,AB,IDIM,IDIM,REST,IGL)
        CALL  PUTAR (IADM,IHZEI,      1,IHBA1-1,C ,IDIM,IDIM,REST,IGL)
        IF (IHZEI.GT.2)
     +    CALL PUTAR (IADM,IHZEI,IHZEI-1,IHBA1-1,B ,IDIM,IDIM,REST,IGL)

      ELSE
*       LAST HYPERLINE IN CASE OF NO CLOSED ZONE
        IF (IH.GT.0) THEN
          DO 92  NH = 1, IHBDI
            IF (IFNH(NH).EQ.1) THEN
*             SUBMATRIX A IS NOT EMTY, TRANSFERE TO HYCHOL
              DO 93  II=1,IDIM
              DO 93  JJ=1,IDIM
93              A (II,JJ) = H (JJ,II,NH)
              IAD = LH - NH + 1
              JAD = NH
              CALL  PUTAR (IADM,IHZEI,IAD,JAD,A,IDIM,IDIM,JLAST,IGL)
            ENDIF
92        CONTINUE
        ENDIF

        IF (REST.NE.0) THEN
          DO 94 I=1,TC
            II = REST0 + I
            AR (II,1) = G0 (I)
            DO 94 J=1,TC
              JJ = REST0 + J
94            AB (II,JJ) = F00 (J,I)

          CALL  PUTAR (IADM,IHZEI,IHZEI,IHBA1-1,AB,IDIM,IDIM,REST,IGL)
          CALL  PUTAR (IADM,IHZEI,IHZEI,IHBA1,  AR,IDIM,  IR,  IR,IGR)
        ENDIF
      ENDIF

*  --10.--  S T A R T   S U B R O U T I N E   H C H O L
      CALL CLOCKM (GOMS)
      PRINT*,'--- START   H C H O L         CPU-TIME= ',GOMS,' MILLISEC'
*  FORMATION OF LINEAR EQUATION SYSTEM FAILED IF...
      IF(KKKK.NE.0) GOTO 1000
      PRINT*,' '
      PRINT*,'*******************************************************'
      PRINT*,'INPUT  FROM  - R S N -  FINISHED      START   H C H O L'
      PRINT*,'*******************************************************'
      PRINT*,' '
      CALL  HCHOL (IADM,IHZEI,IHBA1,IHZEI,IHBDI,IHBRA,A,B,C,
     +     IDIM,IR,IGL,IGR)
      CALL CLOCKM (GOMS)
      PRINT*,'--- AFTER   H C H O L         CPU-TIME= ',GOMS,' MILLISEC'
*  SOLUTION OF LINEAR EQUATION SYSTEM FAILED IF...
      IF(KKKK.NE.0) GOTO 1000
      PRINT*,'SOLUTION OF LINEAR EQUTION SYSTEM FINISHED + + + + + + +'

*  --11.--   G E T   S O L U T I O N
      IPN = 0
      I   = 0
      INN = IHZEI - IHBRA
      I0  = IHZEI - IHBA1 + 1
      DO 111 N = 1,DIMTI
111     SP(N) = 0.0 D0

      DO 11  N = 1, IHZEI
        II = 0
        CALL  GETAR (IADM,IHZEI,N,IHBA1,A,IDIM,IR,IGR)
*  GET ACTUAL LENGTH OF SOLUTION VECTOR OF ROW N
        K = 1
        IF (N.GT.INN)  K = N - I0
        ILENR (N) = IXY10 (IADM,IHZEI,N,K)

110     CONTINUE
        II = II + 1
        IF (II.GT.ILENR(N)) GOTO 11
        I  = I  + 1
        IF (I.GT.DIMTI) THEN
*         ALL PLATE CONSTANTS OF A PLATE ARE COLLECTED, OUTPUT TO -OUTH-
          IPN = IPN + 1
          WRITE (20) IPN, SP
          DO 112  JJ=1,DIMTI
112         SP (JJ) = 0.0 D0
          I = 1
        ENDIF
        SP (I) = A (II,1)
        GOTO 110
11    CONTINUE

      IF (TC.EQ.0) THEN
        PRINT*,'NO COMMON PLATE CONSTATNTS,  LAST PLATE CONSTANTS = '
        IPN = IPN + 1
        WRITE (6,222) IPN,SP
      ELSE
        IPN = 0
        PRINT*,'LAST PLATE CONSTANTS = COMMON PLATE CONSTANTS :'
        WRITE (6,222) IPN,SP
222     FORMAT (1X,I5,9F14.10)
        WRITE (13)    IPN,SP
      ENDIF

      WRITE (20)  IPN, SP
      CLOSE (20)

*  --12.--  T E S T P R I N T O U T
      CALL CLOCKM (GOMS)
      PRINT*,'--- AFTER  SOLUTION           CPU-TIME= ',GOMS,' MILLISEC'
      PRINT*,' '
      PRINT*,'**********  T E S T P R I N T O U T  ***********'
      OPEN (20,FILE=FNOUTH,FORM='UNFORMATTED')
      IPN0 = 0

12    CONTINUE
        READ (5,*,END=999) IPN1,IPN2
        PRINT*,' '
        PRINT*,'N E W   R A N G E :  IPN1, IPN2 = ',IPN1,IPN2
        PRINT*,'============================================'
        DO 121  I = IPN0+1, IPN1-1
121       READ (20,END=998) J
        DO 122  I = IPN1, IPN2
          READ (20,END=998) IPN, SP
          WRITE (6,222) IPN, SP
122     CONTINUE
        IPN0 = IPN2
      GOTO 12

997   PRINT*,' '
      PRINT*,'END OF FILE ON 12 DURING READ OF NC+1  F MATRICES'
      PRINT*,'LFL, NFL, NC = ',LFL,NFL,NC
      GOTO 999
998   PRINT*,' '
      PRINT*,'END OF FILE ON 20 DURING READ OF -OUTH- , IPN = ',I
      GOTO 999
1000  PRINT*,' '
      PRINT*,' E R R O R   * * *  GOTO 1000   S T O P, KKKK = ',KKKK
999   STOP
      END

      SUBROUTINE MATOUT (MOD,IA,A,N,DIM)
C                                                     CREATION 02.02.87
C  OUTPUT MATRIX. CALCULATE SPUR, MINIMAL ELEMENT.NE.0,
C  ALSO PRINTOUT MATRIX (1 ELEMENT = 1 CHARACTER) WHEN MOD>0
C  UPDATE: LSPUR(06.03.87)
      IMPLICIT LOGICAL (A-Z)
      INTEGER MOD,IA,N,DIM
      REAL*8  A (DIM,DIM)
      INTEGER I,J,K,L,L1,L2,NN
      REAL*8  MIN, LSPUR, AA
      CHARACTER LINE*120

      MIN  = 9.99D66
      LSPUR= 0.0D0

      DO 1 I=1,N
        LSPUR = LSPUR + LOG ( A (I,I) )
        DO 1 J=1,N
          AA = ABS (A(I,J))
1         IF (AA.GT.0.0D0.AND.AA.LT.MIN)  MIN = AA
      WRITE (6,'(1X,A,I4,2D12.3,2X,8D9.2)')
     +  'IA, LOG(SPUR), MIN, A(J,J) = ',IA,LSPUR,MIN,
     +  (A(K,K),K=1,8)

      IF (MOD.LE.0) RETURN

      DO 2 NN=0, N/120
        L1 = 1 + NN*120
        L2 = L1 + 119
        IF (L2.GT.N) L2= N
        PRINT*,'            COLUMNS = ',L1,L2,'                 ',
     +         ' 3:= >1.0D0,  2:= >1.0D-15,  1:= >1.0D-30,  .:= ELSE'

        DO 3 I=1,DIM
          LINE = ' '
          DO 4 L=L1,L2
            J = L - NN*120
            AA = ABS (A(I,L))
            IF (AA.GT.1.0D0) THEN
              LINE (J:J) = '3'
            ELSEIF (AA.GT.1.0D-15) THEN
              LINE (J:J) = '2'
            ELSEIF (AA.GT.1.0D-30) THEN
              LINE (J:J) = '1'
            ELSE
              LINE (J:J) = '.'
            ENDIF
4         CONTINUE
          WRITE (6,'(1X,I5,2X,A)') I,LINE
3       CONTINUE

2     CONTINUE
      RETURN
      END
   
      SUBROUTINE CLOCKM(GOMS)
C     SHOULD RETURN TIME IN SECONDS, BUT WE DON'T KNOW HOW TO DO IT (CAH)
      INTEGER GOMS
      GOMS=0
      RETURN
      END

