C
C =====================================================================
C =========================== G L O B A L =============================
C =====================================================================
C
      SUBROUTINE GLOBAL
C
C =====================================================================
C I                                                                   I
C I     SUBROUTINE GLOBAL IS USED TO MODIFY THE FINAL GLOBAL          I
C I     STIFFNESS MATRIX. THIS IS DONE IN ORDER TO SOLVE THE          I
C I     SET OF SIMULTANEOUS EQUATIONS BY THE METHOD OF MODIFICATION.  I
C I     THIS SUBROUTINE IS DESIGNED FOR MODIFICATION OF BANDED        I
C I     NONSYMMETRIC MATRICES IN THEIR CONDENSED FORM.                I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER ICOUNT,ID,MDOF,NNDF,NNODES,NTDF,IDOF(*)
C
C ======================== E N T R Y    G L O B 1 =====================
C
      ENTRY GLOB1(NNODES,NNDF,NTDF,IDOF)
      MDOF = NNDF*NNODES
      ICOUNT = 0
      DO ID = 1 , MDOF
        IF (IDOF( ID ).EQ.0) THEN
          ICOUNT = ICOUNT + 1
          IDOF( ID ) = ICOUNT
        ELSE IF (IDOF( ID ).GT.0) THEN
          IDOF( ID ) = 0
        END IF
      END DO
      NTDF = ICOUNT
      RETURN
C
C ======================== E N T R Y    G L O B 2 =====================
C
      ENTRY GLOB2(NNODES,NNDF,NTDF,IDOF)
      MDOF = NNDF*NNODES
      ICOUNT = 0
      DO ID = 1 , MDOF
        IF (IDOF( ID ).GT.0) THEN
          ICOUNT  = ICOUNT + 1
          IDOF( ID ) = ICOUNT
        END IF
      END DO
      NTDF = ICOUNT
C
      END
C
C =====================================================================
C ======================== D I A G N L ================================
C =====================================================================
C
      SUBROUTINE DIAGNL(NELEM,NNDF,NTDF,IDOF,JDIAG,NTSK,MBAND,SYMMETRIC,
     .                  I_OUT)
C
C =====================================================================
C I                                                                   I
C I    THIS PROGRAM COMPUTES THE VECTOR CONTAINING THE ADDRESSES      I
C I    OF THE DIAGONAL ELEMENTS OF THE STIFFNESS MATRIX. IT ALSO      I
C I    CALCULATES THE BANDWIDTH AND THE AVERAGE BANDWIDTH OF THE      I
C I    STIFFNESS MATRIX AND PRINTS THESE STATISTICS.                  I
C I                                                                   I
C I    A R G U M E N T      L I S T                                   I
C I                                                                   I
C I    NELEM     = TOTAL NUMBER OF ELEMENTS                           I
C I                                                                   I
C I    NNDF      = NUMBER OF NODAL DEGREES OF FREEDOM                 I
C I                                                                   I
C I    NTDF      = NUMBER OF TOTAL DEGREES OF FREEDOM                 I
C I                                                                   I
C I    IDOF(I)   = VECTOR CONTAINING THE D.O.F. NUMBERS OF THE NODES  I
C I                                                                   I
C I    JDIAG(I)  = VECTOR CONTAINING THE ADDRESS OF THE DIAGONAL      I
C I                TERMS IN THE GLOBAL STIFFNESS MATRIX 'SKG'         I
C I                                                                   I
C I    NTSK      = NUMBER OF TERMS IN THE GLOBAL STIFFNESS MATRIX     I
C I                                                                   I
C I    MBAND     = HALF BANDWIDTH OF THE STIFFNESS MATRIX             I
C I                                                                   I
C I    I_OUT     = OUTPUT DEVICE NUMBER                               I
C I                                                                   I
C I                                                                   I
C I    C O M M O N     B L O C K S                                    I
C I                                                                   I
C I    NOP(I,J)  = MEMBER INCIDENCES                                  I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEMENTS,MAX_ELEM_NODES
      INTEGER ELNUM,ELEM_TYPE,STRS_STRN_REL
      PARAMETER (MAX_ELEMENTS=400,MAX_ELEM_NODES=20)
      LOGICAL SYMMETRIC
      INTEGER IDOF(*), JDIAG(*),NOP,ID,IDIR,ISTART,I_OUT,K,LINES
      INTEGER MATNUM,MAXDOF,MBAND,MBAV,MBN,MHT,MINDOF,NELEM,NNDF,NNEL
      INTEGER NODE,NTDF,NTSK
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
C
      MBAV = 0
      MBAND = 0
      DO K = 1 , NTDF
        JDIAG( K ) = 0
      END DO
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        MAXDOF = 0
        MINDOF = 1000000
        DO 20 NODE = 1 , NNEL
         DO 20 IDIR = 1 , NNDF
           K = NNDF*(NOP(NODE , ELNUM) - 1) + IDIR
           IF(IDOF( K ))20,20,10
 10        MAXDOF = MAX0(MAXDOF , IDOF( K ))
           MINDOF = MIN0(MINDOF , IDOF( K ))
 20     CONTINUE
C
C        AT THIS POINT THE HEIGHT OF EACH COLUMN IS STORED IN JDIAG
C
        DO 26 NODE = 1 , NNEL
          DO 26 IDIR = 1 , NNDF
            ID = NNDF*(NOP(NODE , ELNUM) - 1) + IDIR
            ID = IDOF( ID )
            IF ( ID )26 , 26 , 25
 25         MHT = ID - MINDOF + 1
            IF(MHT.GT.JDIAG( ID )) JDIAG( ID ) = MHT
 26     CONTINUE
C
C        FIND THE BANDWIDTH AND THE AVERAGE BANDWIDTH
C
        MBN = MAXDOF - MINDOF
        MBAND = MAX0(MBAND , MBN)
        MBAV = MBAV + MBAND
      END DO
      MBAV = MBAV/NELEM + 1
      MBAND = MBAND + 1
C
C        LOCATION OF EACH DIAGONAL TERM WILL NOW BE STORED IN JDIAG
C
      IF (SYMMETRIC) THEN
        MHT = 1
        ID  = 0
        DO K = 1 , NTDF+1
          ID = ID + MHT
          MHT = JDIAG( K )
          JDIAG( K ) = ID
        END DO
        NTSK = JDIAG(NTDF+1) - JDIAG( 1 )
      ELSE
        ID = 0
        DO K = 1 , NTDF
          ID = ID + JDIAG( K )
          JDIAG( K ) = ID
        END DO
        NTSK = 2*JDIAG( NTDF )
      END IF
C
C        NTSK = NUMBER OF TERMS IN THE GLOBAL STIFFNESS MATRIX "SKG"
C
      WRITE(I_OUT , 100)NTDF,MBAND,MBAV,NTSK
 100  FORMAT(/1X,'NUMBER OF EQUATIONS = ',I8/1X,'HALF BANDWIDTH = ',
     . I8/1X,'AVERAGE BANDWIDTH = ',I8/1X,'SIZE OF THE STIFFNESS MATRIX'
     . ,' = ',I8)
C
      END
C
C =====================================================================
C ========================== S O L V E 1 ==============================
C =====================================================================
C
      SUBROUTINE SOLVE1(A,C,B,JDIAG,NEQ,AFAC,BACK)
C
C ====================================================================
C I                                                                  I
C I   P R O G R A M:                                                 I
C I                                                                  I
C I   PROGRAM 'SOLVE1' IS USED TO SOLVE A SERIES OF BANDED           I
C I   NONSYMMETRIC LINEAR EQUATIONS USING THE GAUSS ELIMINATION/BACK I
C I   SUBSTITUTION WITH NO COLUMN PIVOTING.                          I
C I                                                                  I
C I   STORAGE:    COEFFICIENT MATRIX SHOULD BE STORED IN TWO ONE     I
C I               DIMENSIONAL ARRAYS USING THE SKYLINE OR THE        I
C I               PROFILE METHOD                                     I
C I               A( K ) = UPPER TRIANGULAR MATRIX                   I
C I               C( K ) = LOWER TRIANGULAR MATRIC                   I
C I               B( K ) = RIGHT HAND SIDE VECTOR ON CALL            I
C I                      = VECTOR OF UNKNOWNS ON RETURN              I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      LOGICAL AFAC,BACK
      INTEGER I,ID,IE,IH,IR,IS,J,JD,JH,JR,K,NEQ,JDIAG(*)
      REAL*8 A(*),C(*),B(*),D,DOTPRO
C
C        FACTOR A TO UT*D*U, REDUCE B TO Y
C
      JR = 0
      DO 300 J = 1 , NEQ
        JD = JDIAG( J )
        JH = JD - JR
        IF (JH.LE.1) GO TO 300
        IS = J + 1 - JH
        IE = J - 1
        IF (.NOT.AFAC) GO TO 250
        K = JR + 1
        ID = 0
C
C        REDUCE ALL EQUATIONS EXCEPT DIAGONAL
C
        DO I = IS , IE
          IR = ID
          ID = JDIAG( I )
          IH = MIN0(ID-IR-1 , I - IS)
          IF (IH.EQ.0) GO TO 150
          A( K ) = A( K ) - DOTPRO(A( K-IH ),C( ID-IH ),IH)
          C( K ) = C( K ) - DOTPRO(C( K-IH ),A( ID-IH ),IH)
 150      IF (A(ID).NE.0.0) C( K ) = C( K )/A( ID )
          K = K + 1
        END DO
C
C         REDUCE THE DIAGONAL TERM
C
        A( JD ) = A( JD ) - DOTPRO(A( JR+1 ),C( JR+1 ),JH-1)
C
C         FORWARD REDUCE THE RIGHT HAND SIDE
C
 250    IF ( BACK ) B( J ) = B( J ) - DOTPRO(C( JR+1 ),B( IS ),JH-1)
 300  JR = JD
      IF(.NOT.BACK) RETURN
C
C         BACK SUBSTITUTION
C
      J = NEQ
      JD = JDIAG( J )
 500  IF (A( JD ).NE.0.0) B( J ) = B( J )/A( JD )
      D = B( J )
      J = J - 1
      IF (J.LE.0) RETURN
      JR = JDIAG( J )
      IF (JD-JR.LE.1) GO TO 700
      IS = J - JD + JR + 2
      K = JR - IS + 1
      DO I = IS , J
        B( I ) = B( I ) - A( I+K )*D
      END DO
 700  JD = JR
      GO TO 500
C
      END
C
C =====================================================================
C ============================= D O T P R O ===========================
C =====================================================================
C
      REAL*8 FUNCTION DOTPRO(A,B,N)
      IMPLICIT NONE
      REAL*8 A(*),B(*),TEMP
      INTEGER I,N
C
      TEMP = 0.D0
      DO I = 1 , N
        TEMP = TEMP + A( I )*B( I )
      END DO
      DOTPRO = TEMP
C
      END
C
C =====================================================================
C ========================== S O L V E 2 ==============================
C =====================================================================
C
      SUBROUTINE SOLVE2(A,R,JDIAG,NEQU,KKK,I_OUT)
C
C ====================================================================
C I                                                                  I
C I   THIS PROGRAM IS USED TO SOLVE FINITE ELEMENT STATIC EQUILIB.   I
C I   EQUATIONS IN CORE, USING COMPACTED STORAGE AND COLUMN REDUCTON I
C I   SCHEME                                                         I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      INTEGER IC,I_OUT,J,K,KH,KI,KK,KKK,KL,KLT,KN,KU,L,N,ND,NEQU
      INTEGER JDIAG(*)
      REAL*8 A(*),R(*),B,C
C
C        PERFORM L*D*L FACTORIZATION OF THE STIFFNESS MATRIX
C
      IF (KKK - 2) 40 , 150 , 150
 40   DO 140 N = 1 , NEQU
        KN = JDIAG( N )
        KL = KN + 1
        KU = JDIAG(N+1) - 1
        KH = KU - KL
        IF (KH) 110,90,50
 50     K = N - KH
        IC = 0
        KLT = KU
        DO 80 J = 1 , KH
          IC = IC + 1
          KLT = KLT - 1
          KI = JDIAG( K )
          ND = JDIAG( K + 1 ) - KI - 1
          IF (ND) 80 , 80 , 60
 60       KK = MIN0(IC,ND)
          C = 0.D0
          DO L = 1 , KK
            C = C + A(KI + L)*A(KLT + L)
          END DO
          A( KLT ) = A( KLT ) - C
 80     K = K + 1
 90     K = N
        B = 0.D0
        DO KK = KL , KU
          K = K - 1
          KI = JDIAG( K )
          C = A( KK )/ A( KI )
          B = B + C*A( KK )
          A( KK ) = C
        END DO
        A( KN ) = A( KN ) - B
 110    IF (A( KN )) 120 ,120 , 140
 120    WRITE(I_OUT , 2000) N , A( KN )
        STOP 'STIFFNESS MATRIX NOT POSITIVE DEFINITE '
 140  CONTINUE
      RETURN
C
C       REDUCE THE RIGHT-HAND-SIDE LOAD VECTOR
C
 150  DO 180 N = 1 , NEQU
        KL = JDIAG( N ) + 1
        KU = JDIAG( N + 1) - 1
        IF(KU-KL) 180 , 160 , 160
 160    K = N
        C = 0.D0
        DO KK = KL , KU
          K = K - 1
          C = C + A( KK )*R( K )
        END DO
        R( N ) = R( N ) - C
 180  CONTINUE
C
C       BACK-SUBSTITUTE
C
      DO N = 1 , NEQU
        K = JDIAG( N )
        R( N ) = R( N )/ A( K )
      END DO
      IF (NEQU.EQ.1) RETURN
      N = NEQU
      DO 230 L = 2 , NEQU
        KL = JDIAG( N ) + 1
        KU = JDIAG( N + 1 ) - 1
        IF ( KU - KL ) 230 , 210 , 210
 210    K = N
        DO KK = KL , KU
          K = K - 1
          R( K )  = R( K ) - A( KK )*R( N )
        END DO
 230  N = N - 1
      RETURN
 2000 FORMAT(//1X,'STIFFNESS MATRIX NOT POSITIVE DEFINITE '//
     . 1X,' NONPOSITIVE PIVOT FOR EQUATION ',I4//1X,'PIVOT = ',E20.12)
C
      END
