      SUBROUTINE  APLYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 
     1                    NDFREE, NCOEFF, SS, CC, IBW, 
     2                    IDIAG, MODE )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C            APPLY BOUNDARY CONSTRAINT EQUATIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  SS(NCOEFF), CC(NDFREE), NREQ(MAXACT),
     1           CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE),
     2           IDIAG(NDFREE)
C     CC        = SYS. EQ. COL. MATRIX
C     CEQ(I,J)  = CONSTRAINT EQS COEFF I FOR EQ J
C     IBW       = CURRENT BAND, GROWS WITH CONSTRAINTS
C     IDIAG     = SKY DIAGONAL POINTER FOR EACH DOF
C     MAXBAN    = MAX. HALF-BANDWIDTH OF SYSTEM EQUATIONS
C     MODE      = STORAGE MODE, 0-SKY, 1-BANDED
C     NCOEFF    = NUMBER OF COEFFICIENTS IN SS
C     NDFREE    = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NDXC(I,J) = CONSTRAINT EQS DOF NO I FOR EQ J
C     NG        = NO. PARAMETERS PER NODE
C     NREQ      = NO OF CONSTRAINT EQS OF EACH TYPE
C     NUMCE     = NUMBER OF CONSTRAINT EQUATIONS
C     SS        = SYS. EQ. SQ. MATRIX
      IF ( MODE .EQ. 0 )  THEN
C        SKYLINE MODE
c       CALL  SKYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 
c    1               NDFREE, NCOEFF, SS, CC, IDIAG )     
      ELSE
C        BANDED MODE
        MAXBAN = NCOEFF/NDFREE
        CALL  BANDBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 
     1                NDFREE, MAXBAN, SS, CC, IBW )
      ENDIF
      RETURN
      END
      SUBROUTINE  ASYMBL (NG, NCOEFF, MODE, IDIAG, NODES, SS, CC, 
     1    M, NE, NDFREE, NITER, LPTEST, LHOMO, NHOMO, NULCOL, N, 
     2    NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, NNPFLO, 
     3    MISCFX, MISCFL, NLPFIX, NLPFLO, LNODE, INDEX, X, DDOLD, 
     4    COORD, S, C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, 
     5    BODY, PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 
     6    PRTLPT, FLTNP, FLTEL, FLTMIS, ELPROP, PRTMAT, 
     7    MISFIX, NPFIX, LPFIX, LPROP, LPPROP, NTAPE1, NTAPE2, 
     8    NTAPE3, NTAPE4, NTAPE5, LTYPE, NLTYPE, LTDATA, LSHAPE, 
     9    GPT, GWT ) 
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C               ASSEMBLE SYSTEM EQUATIONS AND STORE POST
C                         SOLUTION ELEMENT DATA
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DATA  LASTLT, LTFREE  / 0, 0 /
      DIMENSION  CC(NDFREE), SS(NCOEFF), IDIAG(NDFREE), NODES(NE,N),
     1           LTYPE(NE), LTDATA(6,NLTYPE)
C       JUST PASSING THROUGH: SYSTEM DATA
      DIMENSION  X(M,NSPACE), DDOLD(NDFREE), LNODE(N), INDEX(NELFRE)
C       SYSTEM PROPERTIES
      DIMENSION  PRTLPT(N,0:NNPFLO), FLTNP(M,0:NNPFLO),
     1           FLTEL(NE,0:NLPFLO), NPFIX(M,0:NNPFIX), 
     2           LPFIX(NE,0:NLPFIX)
C      FOR USE IN ELSQ, ELCOL, OR ELPOST:
      DIMENSION  COORD(N,NSPACE), S(NELFRE,NELFRE), C(NELFRE), 
     1           H(N,0:NQP), DGH(NSPACE,N), B(NRB,NELFRE), 
     2           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     3           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE),
     4           PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N,0:NQP), 
     5           G(NGEOM,0:NQP), DLG(NPARM,NGEOM,0:NQP), 
     6           AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), 
     7           HINTG(N,0:NQP+1), GPT(0:NQP), GWT(0:NQP), 
     8           XYZ(NSPACE), D(NELFRE), FLTMIS(0:MISCFL), 
     9           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     1           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     2           LPPROP(0:NNPFIX)
C                       VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     CC      = SYSTEM EQUATIONS COLUMN MATRIX
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DDOLD   = SYSTEM NODAL PARAMETERS FROM LAST ITERATION
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF REAL PROPERTIES
C     FLTEL   = REAL PROPERTIES OF ELEMENTS
C     FLTMIS  = MISCELLANEOUS REAL PROPERTIES OF SYSTEM
C     FLTNP   = REAL PROPERTIES OF SYSTEM NODES
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     IDIAG   = DIAGONAL LOCATION IN SKYLINE VECTOR
C     INDEX   = SYSTEM DOF NUMBERS ASSOCIATED WITH ELEMENT
C     LHOMO   = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS
C     LNODE   = THE N ELEMENT INCIDENCES OF THE ELEMENT
C     LPFIX   = SYSTEM ARRAY OF INTEGER ELEM PROPERTIES
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER ELEMENT PROPERTIES
C     LPTEST  > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED
C     LSHAPE  = SHAPE FLAG FOR QUADRATURE RULE SELECTION
C     LTQP    = NUMBER OF QUADRATURE PTS FOR ELEMENT TYPE
C     LTYPE   = ELEMENT TYPE NUMBER
C     M       = NUMBER OF SYSTEM NODES
C     MODE    = MODE OF STORAGE, 0-SKYLINE, 1-BANDED
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NCOEFF  = TOTAL NUMBER OF TERMS IN SS
C     NDFREE  = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NE      = NUMBER OF ELEMENTS
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NG      = NUMBER OF PARAMETERS PER NODE
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NHOMO   = 1, IF NODAL PROPERTIES ARE HOMOGENEOUS
C     NITER   = NO. OF ITERATIONS TO BE RUN (USUALLY 1)
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NODES   = NODAL INCIDENCES OF ALL ELEMENTS
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NPFIX   = INTEGER PROPERTIES AT ALL NODES
C     NQP     = NUMBER OF QUADRATURE POINTS, >= LTQP
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     NULCOL  > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     SS      = SYSTEM EQUATIONS SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     WT      = QUADRATURE WEIGHTS
C     X       = COORDINATES OF SYSTEM NODES
C     XYZ     = SPACE COORDINATES AT A POINT
C
C     GENERATE ELEMENT EQUATIONS & POST SOLUTION MATRICES
      DO 10  IE = 1, NE
C-->     GET ELEMENT TYPE NUMBER
        LT = 1
        IF ( NLTYPE .GT. 1 )  LT = LTYPE(IE) 
C        SAME AS LAST TYPE ?
        IF ( LT .NE. LASTLT )  THEN
          LASTLT = LT
C          GET CONTROLS FOR THIS TYPE
          CALL  GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM,
     1                 LTPARM, LTSHAP, LTUSER )
          LTFREE = LTN*NG
C-->       GET QUADRATURE RULE FOR ELEMENT TYPE AND SHAPE
          IF ( LTQP .GT. 0 )  THEN
            IF ( LTQP .GT. NQP ) STOP 'LTQP > NQP IN ASYMBL'
            CALL  GETQD (LTSHAP, LTQP, NSPACE, GPT, GWT, PT, WT)
          ENDIF
        ENDIF
C-->     EXTRACT ELEMENT NODE NUMBERS
        CALL  LNODES (IE, NE, LTN, NODES, LNODE)
C-->     CALCULATE DEGREE OF FREEDOM NUMBERS
        CALL  INDXEL (LTN, LTFREE, NG, LNODE, INDEX)
C-->     GENERATE ELEMENT PROBLEM DEPENDENT MATRICES
        CALL  GENELM ( IE, M, NE, NDFREE, NITER, LPTEST, LHOMO, 
     1        NHOMO, NULCOL, LTN, NSPACE, LTFREE, NRB, LTQP, 
     2        LTGEOM, LTPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, 
     3        NLPFIX, NLPFLO, LNODE, INDEX, X, DDOLD, COORD, S, 
     4        C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 
     5        PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 
     6        PRTLPT, FLTNP, FLTEL, FLTMIS, ELPROP, 
     7        PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, LPPROP, 
     8        NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, LT, 
     9        LTSHAP, LTUSER, NG )
C-->     STORE THE MATRICES IN SYSTEM EQUATIONS
        IF ( MODE .EQ. 0 )  THEN
C          SKYLINE VECTOR STORAGE MODE
c         CALL  SKYSTR (NCOEFF, NDFREE, LTFREE, INDEX, IDIAG, 
c    1                  S, SS)
        ELSE
C          BANDED STORAGE
          MAXBAN = NCOEFF/NDFREE
          CALL  STORSQ (NDFREE, MAXBAN, LTFREE, INDEX, S, SS)
        ENDIF
        IF ( NULCOL .EQ. 0 )  
     1       CALL STORCL (NDFREE, LTFREE, INDEX, C, CC)
 10   CONTINUE
C      ASSEMBLY COMPLETED
      RETURN
      END
      SUBROUTINE  AT (N)
      WRITE (6,10) N
 10   FORMAT(' -------->>> HERE AT ',I8)
      RETURN
      END
      SUBROUTINE  BANCHK (NDFREE, MAXBAN, M, NG, S, C)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C      CHECK BANDED SYSTEM FOR INVALID EQUATIONS & WARN
C     * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H, O-Z)
      PARAMETER ( NPRT = 6, ZERO = 0.0 )
      DIMENSION  S(NDFREE,MAXBAN), C(NDFREE)
C     C      = SYSTEM COLUMN MATRIX
C     S      = SYSTEM SQUARE MATRIX IN BANDED MODE
C     NDFREE = NUMBER OF EQUATIONS
C     MAXBAN = HALF BANDWIDTH INCLUDING DIAGONAL
      SMAX = ZERO
      DO 10 I = 1, NDFREE
        TEST = ABS( S(I,1) )
        IF ( TEST .GT. SMAX ) SMAX = TEST
  10  CONTINUE
      IF ( SMAX .LE. ZERO )  STOP  
     1    'ALL ELEMENT STIFFENESSES ZERO, BANCHK'
      K = 0
      DO 20 I = 1, M
        DO 30 J = 1, NG
          K = K + 1
          TEST = S(K,1)
          IF ( TEST .LE. ZERO  )  THEN
            IF ( TEST .EQ. ZERO  )  WRITE (NPRT,200) I, J
 200        FORMAT ('WARNING, NODE ',I5,' DOF',I3,' WAS RESTRAINED')
            IF ( TEST .LT. ZERO  )  WRITE (NPRT,300) I, J
 300        FORMAT ('ERROR, NODE ',I5,' DOF',I3,' WAS RESTRAINED')
            CALL MODFY1 (NDFREE, MAXBAN, K, ZERO, S, C)
          ENDIF
  30    CONTINUE
  20  CONTINUE
      RETURN
      END
      SUBROUTINE  BANDBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 
     1                    NDFREE, MAXBAN, SS, CC, IBW )
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY BOUNDARY CONSTRAINT EQUATIONS TO BANDED EQS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION SS(NDFREE,MAXBAN), CC(NDFREE), NREQ(MAXACT),
     1          CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE)
C     IBW       = CURRENT BAND, GROWS WITH CONSTRAINTS
C     NDFREE    = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     MAXBAN    = MAX. HALF-BANDWIDTH OF SYSTEM EQUATIONS
C     SS        = SYS. EQ. SQ. MATRIX
C     CC        = SYS. EQ. COL. MATRIX
C     NG        = NO. PARAMETERS PER NODE
C     NREQ      = NO OF CONSTRAINT EQS OF EACH TYPE
C     CEQ(I,J)  = CONSTRAINT EQS COEFF I FOR EQ J
C     NDXC(I,J) = CONSTRAINT EQS DOF NO I FOR EQ J
C     NUMCE     = NUMBER OF CONSTRAINT EQUATIONS
      IEQ = 0
c     call iprint(nreq,1,maxact)
c     call iprint(ndxc,maxact,numce)
c     call rprint(ceq,maxact,numce,0)
C      DO TYPE ONE LAST
c     DO 40  IC = MAXACT,1,-1
      DO 40  IC = 1, MAXACT
        NTEST = NREQ(IC)
        IF ( NTEST .GT. 0 )  THEN   
          IF ( IC .EQ. 1 )  THEN
C-->         TYPE 1     D(L1) = C1
            DO 10  NEQ = 1, NTEST
              IEQ = IEQ + 1
              L1  = NDXC(1,IEQ)
              C1  = CEQ(1,IEQ)
c            write(6,*) NDFREE, MAXBAN, IBW, L1, C1
 10         CALL  MODFY1 (NDFREE, MAXBAN, L1, C1, SS, CC)
          ELSEIF ( IC .EQ. 2 )  THEN
C-->         TYPE 2   D(L1)+C1*D(L2)=C2
            DO 20  NEQ = 1, NTEST
              IEQ = IEQ + 1
              L1  = NDXC(1,IEQ)
              L2  = NDXC(2,IEQ)
              C1  = CEQ(1,IEQ)
              C2  = CEQ(2,IEQ)
c            write(6,*) NDFREE, MAXBAN, IBW, L1, L2, C1, C2
 20         CALL  MODFY2 (NDFREE, MAXBAN, IBW, L1, L2, C1, C2, 
     1                    SS, CC)
          ELSEIF ( IC .EQ. 3 )  THEN
C-->         TYPE 3   D(L1)+C1*D(L2)+C2*D(L3)=C3
            DO 30  NEQ = 1,NTEST
              IEQ = IEQ + 1
              L1  = NDXC(1,IEQ)
              L2  = NDXC(2,IEQ)
              L3  = NDXC(3,IEQ)
              C1  = CEQ(1,IEQ)
              C2  = CEQ(2,IEQ)
              C3  = CEQ(3,IEQ)
 30         CALL  MODFY3 (NDFREE, MAXBAN, IBW, L1, L2, L3, C1, 
     1                    C2, C3, SS, CC)
          ELSEIF ( IC .GT. 3 )  THEN
C            OTHER TYPES NOT DEFINED
            STOP 'BANLCE NOT INSTALLED, BANDBC'
          ENDIF
        ENDIF
 40   CONTINUE
      RETURN
      END
      SUBROUTINE  BANMLT (NDFREE, MAXBAN, SS, DD, CC, IOPT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     MULTIPLY PACKED SQUARE MATRIX, SS, BY MATRIX DD
C        IF IOPT = 0 STORE RESULT IN MATRIX CC
C        OTHERWISE ADD RESULT TO MATRIX CC
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  SS(NDFREE,MAXBAN), DD(NDFREE), CC(NDFREE)
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     MAXBAN = SYSTEM HALF BANDWIDTH
      MBM1 = MAXBAN - 1
      DO 70  I = 1, NDFREE
        SUM = 0.0
        J1 = I - MBM1
        J2 = I + MBM1
        J1 = MAX0 (J1,1)
        J2 = MIN0(J2,NDFREE)
        DO 50  J = J1,J2
          IF ( J - I )  10,20,30
   10       JJ = I-J+1
            II = J
            GO TO 40
   20       JJ = 1
            II = I
            GO TO 40
   30       JJ = J-I+1
            II = I
   40       SUM = SUM + SS(II,JJ)*DD(J)
   50   CONTINUE
        IF ( IOPT .EQ. 0 )  THEN
          CC(I) = SUM
        ELSE
          CC(I) = CC(I) + SUM
        ENDIF
   70 CONTINUE
      RETURN
      END
      SUBROUTINE  BANSUB (I, J, K, L)
C     * * * * * * * * * * * * * * * * * * * * * *
C     CONVERT SUBSCRIPTS (I,J) OF SYMMETRIC MATRIX
C     TO SUBSCRIPTS (K,L) IN UPPER HALF BANDWIDTH
C     * * * * * * * * * * * * * * * * * * * * * *
      ITEST = I - J
      IF ( ITEST )  10, 20, 30
C      BELOW DIAGONAL
 10   K = I
      L = 1 - ITEST
      RETURN
C      ON DIAGONAL
 20   K = I
      L = 1
      RETURN
C      ABOVE DIAGONAL
 30   K = J
      L = 1 + ITEST
      RETURN
      END
      SUBROUTINE  BARPRT (M,NDFREE,NG,NSPACE,IBAR,IPARM,
     1                    NODIST,X,D,NODBAR)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     PRINT-PLOT BAR CHARTS OF NODAL PARAMETER IPARM AT
C     THE NODES IN ARRAY NODBAR AND SCALE THE RELATIVE
C     DISTANCE BETWEEN THE POINTS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NPRT = 6, MID = 25, LINE = 2*MID )
      DIMENSION  X(M,NSPACE), D(NDFREE), NODBAR(IBAR)
      DIMENSION  ALINE(LINE+1), SKIP(LINE+1)
      DATA  BLANK,DOT,DASH,AX,PLUS/' ','0','-','X','+'/
      DATA   NOPLOT / 0 /
C     M      = TOTAL NUMBER OF NODES IN SYSTEM
C     IPARM  = NODAL PARAMETER TO BE GRAPHED,1<=IPARM<=NG
C     NODBAR = LIST OF NODES TO BE USED (WHEN IBAR.GT.1)
C     NODIST = 0  OMIT DISTANCES BETWEEN NODAL BAR LINES
C     X      = ARRAY OF GLOBAL COORDINATES OF ALL NODES
C     NDFREE = TOTAL NO. OF DEGREES OF FREEDOM IN SYSTEM
C     D      = ARRAY OF ALL NODAL PARAMETERS IN THE SYSTEM
C     NG     = NUMBER OF PARAMETERS PER NODE
C     NSPACE = DIMENSION OF SOLUTION SPACE
C     IBAR   = NUMBER OF NODES TO BE INCLUDED IN BAR CHART
C        IF IBAR=1  USE ALL NODES , NODBAR NOT USED
CDP   SQRT(Z) = DSQRT(Z)
CDP   ABS(Z) = DABS(Z)
      NOPLOT = NOPLOT + 1
      LIMIT = IBAR
      IF ( LIMIT .LT. 2 )  LIMIT = M
      WRITE (NPRT,5000)  NOPLOT,IPARM,LIMIT
 5000 FORMAT (/, '*** PRINT PLOT NUMBER',I3,' ***',/,
     1           'NODAL PARAMETER', I3,
     2           ', EVALUATED AT ',I5,' NODE POINTS',/)
      IPMNG = IPARM - NG
      IF ( NODIST .EQ. 0 )  GO TO 40
C     FIND MINIMUM DISTANCE BETWEEN POINTS
      DMINSQ = 0.0
      DO 10  IS = 1,NSPACE
   10 DMINSQ = DMINSQ + ( X(2,IS) - X(1,IS) )**2
      DO 30  J = 2,LIMIT
        I = J
        IF ( IBAR .GT. 1 )  I = NODBAR(J)
        DTEST = 0.0
        DO 20  IS = 1,NSPACE
   20   DTEST = DTEST + ( X(I,IS) - X(I-1,IS) )**2
        IF ( DTEST .LT. DMINSQ )  DMINSQ = DTEST
   30 CONTINUE
      DMIN = SQRT(DMINSQ)
C-->  ESTABLISH GRAPH LIMITING VALUES
   40 YMAX = 0.0
      DO 50  I = 1,LIMIT
        N = I
        IF ( IBAR .GT. 1 )  N = NODBAR(I)
        INDEX = NG*N + IPMNG
        DTEST = ABS(D(INDEX))
        IF ( DTEST .GT. YMAX )  YMAX = DTEST
   50 CONTINUE
      KOUNT = 1
   60 IF ( YMAX .LT. 10.0 )  GO TO 70
        KOUNT = KOUNT + 1
        YMAX = YMAX*0.1
        GO TO 60
   70 YSCALE = 10.**KOUNT
      IF ( YMAX .LT. 5.0 )  YSCALE = YSCALE*0.5
      IF ( YMAX .LT. 2.0 )  YSCALE = YSCALE*0.4
      IF ( YMAX .LT. 1.0 )  YSCALE = YSCALE*0.05
      WRITE (NPRT,5010)  YSCALE
 5010 FORMAT (' RANGE ON GRAPH IS +/- ',1PE12.5,/)
      CONST = FLOAT(LINE)/(YSCALE + YSCALE)
      DO 80  I = 2,LINE
      SKIP(I)  = BLANK
   80 ALINE(I) = DASH
      SKIP(1)  = PLUS
      SKIP(MID+1)  = DOT
      SKIP(LINE+1)  = PLUS
      DO 90  I = 1,LINE+1,5
   90 ALINE(I) = PLUS
      ALINE(MID+1) = DOT
      WRITE (NPRT,5020)  ALINE
 5020 FORMAT(' NODE    VALUE   ', (101A1) )
      DO 100  I = 2,LINE
  100 ALINE(I) = BLANK
      N = 1
      IF ( IBAR .GT. 1 )  N = NODBAR(1)
      DO 210  K = 1,LIMIT
        NLAST = N
        N = K
        IF ( IBAR .GT. 1 )  N = NODBAR(K)
        INDEX = NG*N + IPMNG
        JY = ( D(INDEX) + YSCALE )*CONST + 1.4
        ALINE(1) = PLUS
        ALINE(MID+1) = DOT
        ALINE(LINE+1) = PLUS
        ISPACE = 1
        IF ( NODIST .EQ. 0 )  GO TO 120
C-->      FIND DISTANCE BETWEEN TWO POINTS
          DIST = 0.0
          DO 110  IS = 1,NSPACE
  110     DIST = DIST + ( X(N,IS)-X(NLAST,IS) )**2
C         MINIMUM DISTANCE IS ONE SPACE
        DIST = SQRT(DIST)
        IF ( K .NE. 1 )  THEN
          IF ( DMIN .GT. 0.0 )  THEN
            ISPACE = DIST/DMIN + 0.5
          ELSE
            ISPACE = 1
          ENDIF
        ENDIF
      IF ( ISPACE .GT. 10 ) ISPACE = 5
  120 CONTINUE
      IF ( NODIST .GT. 0 .AND. K .GT. 1 )  THEN
        DO 130  I = 1,ISPACE
  130   WRITE (NPRT,5030)  SKIP
 5030   FORMAT (17X, (101A1) )
      ENDIF
      IF ( JY .GT. MID )  GO TO 150
        DO 140  I = JY,MID+1
  140   ALINE(I) = AX
        GO TO 170
  150 DO 160  I = MID+1,JY
  160 ALINE(I) = AX
  170 CONTINUE
      WRITE (NPRT,5040)   N, D(INDEX), ALINE
 5040 FORMAT (I4,2X,1PE10.3,1X,101A1)
      IF ( JY .GT. MID )  GO TO 190
        DO 180  I = JY,MID+1
  180   ALINE(I) = BLANK
        GO TO 210
  190 DO 200  I = MID+1,JY
  200 ALINE(I) = BLANK
  210 CONTINUE
      DO 220  I = 2,LINE
  220 ALINE(I) = DASH
      DO 230  I = 1,LINE+1,5
  230 ALINE(I) = PLUS
      ALINE(MID+1) = DOT
      WRITE (NPRT,5020)  ALINE
      RETURN
      END
      SUBROUTINE  BELAST (IOPT, N, NSPACE, NG, GDH, H, 
     1                    R, NS, B)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     ELASTICITY STRAIN-DISPLACEMENT RELATIONS  (B)
C     * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  GDH(NSPACE,N), B(NS,N*NG), H(N)
C     B      = STRAIN-DISPLACEMENT MATRIX (RETURNED)
C     GDH    = GLOBAL DERIVATIVES OF H
C     H      = ELEMENT INTERPOLATION FUNCTIONS
C     IOPT = ELASTICITY CLASS
C          = 1, AXIAL BAR,    NG = 1  
C          = 2, PLANE STRESS, NG = 2
C          = 3, PLANE STRAIN, NG = 2
C          = 4, AXISYMMETRIC, NG = 2, R = RADIUS
C          = 5, 3-D SOLID,    NG = 3
C     N      = NUMBER OF NODES PER ELEMENT
C     NG     = NUMBER OF PARAMETERS PER NODE
C     NS     = NUMBER OF STRAINS (ROWS IN B)
C     NSPACE = DIMENSION OF SPACE
      IF ( IOPT.LT.1 .OR. IOPT.GT.5 )  STOP 'BELAST'
      DO 70  J = 1, N
        K = NG*(J - 1) + 1
        L = K + 1
        M = L + 1
C-->     ONE-DIMENSIONAL AXIAL BAR, IOPT = 1
        B(1,K) = GDH(1,J)
        IF ( IOPT .EQ. 1 )  GO TO 70
C->        PLANE STRESS, PLANE STRAIN, AXISYMMETRIC, 3D
 20       B(2,K) = 0.0
          B(3,K) = GDH(2,J)
          B(1,L) = 0.0
          B(2,L) = GDH(2,J)
          B(3,L) = GDH(1,J)
          IF ( IOPT.EQ.2 .OR. IOPT.EQ.3 ) GO TO 70
C->          AXISYMMETRIC ONLY
 30         IF ( IOPT .NE. 4 )  GO TO 40
              IF ( R .LE. 0.0 )  STOP 'R=0, BELAST'
              B(4,K) = H(J)/R
              B(4,L) = 0.0
              GO TO 70
C->            3D SOLID ONLY
 40           B(4,K) = 0.0
              B(5,K) = 0.0
              B(6,K) = GDH(3,J)
              B(4,L) = 0.0
              B(5,L) = GDH(3,J)
              B(6,L) = 0.0
              B(1,M) = 0.0
              B(2,M) = 0.0
              B(3,M) = 0.0
              B(4,M) = GDH(3,J)
              B(5,M) = GDH(2,J)
              B(6,M) = GDH(1,J)
 70   CONTINUE
      RETURN
      END
      SUBROUTINE  BFLUX (FLUX, COORD, LBN, N, NSPACE, NFLUX, 
     1            NG, C, S, IOPT, NQP, NPARM, H, DGH, 
     2            PT, WT, XYZ, DLH, G, DLG, AJ, AJINV )
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C         PROBLEM DEPENDENT BOUNDARY FLUX CONTRIBUTIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        ALWAYS USED
      DIMENSION  COORD(LBN,NSPACE), FLUX(LBN,NG), C(NFLUX),
     1           S(NFLUX,NFLUX)
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION   H(N), DGH(NSPACE,N), PT(NPARM,NQP), 
     1            WT(NQP), XYZ(3), DLH(NSPACE,N), G(LBN), 
     2            DLG(NPARM,LBN), AJ(NSPACE,NSPACE), 
     3            AJINV(NSPACE,NSPACE)
C
C     FLUX    = SPECIFIED BOUNDARY FLUX COMPONENTS
C     COORD   = SPATIAL COORDINATES OF SEGMENT NODES
C     LBN     = NO. OF NODES ON AN ELEMENT BOUNDARY SEGMENT
C     NSPACE  = DIMENSION OF SOLUTION SPACE
C     NFLUX   = N*NG = MAXIMUM NUMBER OF FLUX CONTRIBUTIONS
C     C       = BOUNDARY FLUX COLUMN MATRIX CONTRIBUTIONS
C     S       = BOUNDARY FLUX SQUARE MATRIX
C     NG      = NUMBER OF PARAMETERS PER NODE POINT
C     IOPT    = PROBLEM MATRIX REQUIREMENTS, MUST BE SET.
C             = 1, CALCULATE C ONLY
C             = 2, CALCULATE S ONLY
C             = 3, CALCULATE BOTH C AND S
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     N       = NUMBER OF SOLUTION NODES, N = LBN USUALLY
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NPARM   = PARAMETRIC GEOMETRY NODES, = NSPACE USUALLY
C     PT      = QUADRATURE COORDINATES
C     WT      = QUADRATURE WEIGHTS
C     XYZ     = SPACE COORDINATES AT A POINT
      IOPT = 0
C     ....................................................
C       ** BFLUX PROBLEM DEPENDENT STATEMENTS FOLLOW **
C     ....................................................
      RETURN
      END
      SUBROUTINE  BTDB (D, B, S, M, N, IOPT, COEFF)
C     * * * * * * * * * * * * * * * * * * * * * *
C      SPECIAL MATRIX MULTIPLICATION OPERATION
C     IF IOPT=0,  S = (B)T*D*B*COEFF       PRODUCT
C     IF IOPT=1,  S = (B)T*D*B*COEFF + S   NUM. INTG.
C     * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  D(M,M), B(M,N), S(N,N)
C     D(M,M) = SYMMETRIC SQUARE MATRIX
C     B(M,N) = RECTANGLUAR ARRAY
C     S(N,N) = RETURNED SYMMETRIC SQ MATRIX
C     COEFF  = SCALAR COEFFICIENT
      DO 40  L = 1,N
        DO 30  K = 1,N
          SUM = 0.0
          DO 20  I = 1,M
            DBIK = 0.0
            DO 10  J = 1,M
C              USE SYMMETRY OF D
   10       DBIK = DBIK + D(J,I)*B(J,K)
            SUM = SUM + B(I,L)*DBIK
   20     CONTINUE
          IF ( IOPT .EQ. 0 )  THEN
            S(L,K) = SUM*COEFF
          ELSE
            S(L,K) = S(L,K) + SUM*COEFF
          ENDIF
   30   CONTINUE
c  30   S(K,L) = S(L,K)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE  BTDIAB (DIA, B, S, M, N, IOPT, COEFF)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      SPECIAL DIAGONIAL MATRIX MULTIPLICATION OPERATION
C      IF IOPT=0,  S = (B)T*DIA*B*COEFF       PRODUCT ONLY
C      IF IOPT=1,  S = (B)T*DIA*B*COEFF + S   NUM. INTEG.
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DIA(M), B(M,N), S(N,N)
C     DIA(M)   = DIAGONAL MATRIX
C     B(M,N)   = RECTANGLUAR ARRAY
C     S(N,N)   = RETURNED SYMMETRIC SQ MATRIX
C     COEFF    = SCALAR COEFFICIENT
      DO 30  L = 1,N
        DO 20  K = 1,N
          SUM = 0.0
          DO 10  I = 1,M
   10     SUM = SUM + B(I,L)*DIA(I)*B(I,K)
          IF ( IOPT .EQ. 0 )  THEN
            S(L,K) = SUM*COEFF
          ELSE
            S(L,K) = S(L,K) + SUM*COEFF
          ENDIF
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  CALPRT (N, NNPFLO, H, PRTLPT, VALUES)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C       CALCULATE NNPFLO PROPERTIES AT A LOCAL PT USING
C        ELEMENT'S NODAL PROPERTIES, PRTLPT, AND THE N
C          INTERPOLATION FUNCTIONS, H, AT THE POINT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(N), PRTLPT(N,0:NNPFLO), VALUES(0:NNPFLO)
C     N      = NUMBER OF NODES PER ELEMENT
C     NNPFLO = NO. OF FLOATING POINT NODAL PROPERTIES
C     H      = INTERPOLATION FUNCTIONS FOR AN ELEMENT
C     PRTLPT = FLOATING PT PROPS OF ELEMENT'S NODES
C     VALUES = LOCAL VALUES OF PROPERTIES
      IF ( NNPFLO .LT. 1 ) STOP 'NNPFLO = 0, CALPRT'
      DO 20  I = 1, NNPFLO
        SUM = 0.0
        DO 10  J = 1, N
          SUM = SUM + H(J)*PRTLPT(J,I)
 10     CONTINUE
        VALUES(I) = SUM
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  CCOUNT (M, NG, NRES, IBC, KODES, MAXACT, 
     1                    NUMCE, MAXTYP, NREQ)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CALCULATE NUMBER OF CONSTRAINT FLAGS OF EACH TYPE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( NPRT = 6, NBUG = 6)
      DIMENSION  IBC(M), NRES(MAXTYP), KODES(NG), 
     1           NREQ(MAXTYP)
C     M      = TOTAL NUMBER OF SYSTEM NODES
C     NG     = NO. OF PARAMETERS (DOF) PER NODE
C     IBC    = NODAL POINT BOUNDARY RESTRAINT INDICATOR
C     KODES  = LIST OF RESTRAINT INDICATORS AT A NODE
C     NRES   = LIST OF NUMBER OF FLAGS OF EACH TYPE
C            = NUMBER OF CONSTR EQS ON EXIT, NREQ
C     MAXTYP = MAX NO OF DIFFERENT CONSTRAINT TYPES
C     MAXACT = ACTIVE NO OF TYPES
C      INITIALIZATION
      DO 10  I = 1, MAXTYP
 10   NRES(I) = 0
      DO 30  I = 1, M
C        DOES NODE I HAVE A NODAL PARAMETER CONSTRAINT
        ITEST = IABS( IBC(I) )
        IF ( ITEST .GT. 0 )  THEN
C          EXTRACT PARAMETER CODES
          CALL  PTCODE (I,NG,ITEST,KODES)
          DO 20  J = 1, NG
            K = KODES(J)
C            UPDATE CONSTRAINT COUNTERS
            IF ( K .GT. 0 )  NRES(K) = NRES(K) + 1
 20       CONTINUE
        ENDIF
 30   CONTINUE
C      CONVERT TO EQUATION COUNTERS
      NUMCE  = 0
      MAXACT = 1
      WRITE (NPRT,5000)
 5000 FORMAT ( /,
     1 '***  NODAL PARAMETER CONSTRAINT LIST  ***', /, 
     2 'TYPE      EQUATIONS')
      DO 40  I = 1, MAXTYP
        K = NRES(I)
        IF ( K .GT. 0 )  MAXACT = I
        IF ( ((K/I)*I) .LT. K )  WRITE (NBUG,*)
     1    'INVALID DATA FOR TYPE', I
        NREQ(I) = NRES(I)/I
        IF ( NREQ(I) .GT. 0 )  WRITE (NPRT,5020)  I, NREQ(I)
 5020   FORMAT ( I4, I10 )
 40   NUMCE = NUMCE + NREQ(I)
      RETURN
      END
      SUBROUTINE  CEQBAN (JBW, NREQ, MAXACT, NUMCE, 
     1                    NDXC, NDFREE)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C        FIND MAXIMUM HALF BANDWIDTH REQUIRED BY
C      CONSTRAINT EQUATION MODIFICATION PROCEDURES
C     * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  NDXC(MAXACT,NUMCE), NREQ(MAXACT)
C     JBW       = MAX HALF BAND FROM CONSTRAINT EQUATIONS 
C     MAXACT    = NUMBER ACTIVE CONSTRAINT TYPES
C     NUMCE     = TOTAL NUMBER CONSTRAINT EQS
C     NDXC(I,J) = CONSTR DOF NO I OF EQ J
C     NDFREE    = TOTAL NO OF SYSTEM DEGREES OF FREEDOM
      JBW = 1
      IEQ = NREQ(1)
C-->   LOOP OVER NON DIAGONAL CONSTRAINTS
      DO 30  IC = 2, MAXACT
        NTEST = NREQ(IC)
        IF ( NTEST .GT. 0 )  THEN
C-->       LOOP OVER TYPE IC EQUATIONS
          DO 20  J = 1, NTEST
            IEQ  = IEQ + 1
            IMIN = NDXC(1,IEQ)
            IMAX = IMIN
C-->         FIND EQUATION BANDWIDTH
            DO 10  I = 1, IC
              INDEX = NDXC(I,IEQ)
              IF ( INDEX .LT. IMIN ) IMIN = INDEX
 10         IF ( INDEX .GT. IMAX ) IMAX = INDEX
            LBW = IMAX - IMIN + 1
C            UPDATE MAXIMUM
            IF ( LBW .GT. JBW ) JBW = LBW
 20       CONTINUE
        ENDIF
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  CHANGE (NDFREE, DD, DDOLD, TOTAL, DIFF, 
     1                    RATIO, IPRINT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CALCULATE THE MEAN CHANGE IN NODAL PARAMETERS FROM
C                      THE LAST ITERATION
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  DD(NDFREE), DDOLD(NDFREE)
C     * CHANGE SHOULD BE CALLED BEFORE CORECT *
C     RATIO  = DIFF/TOTAL
C     DIFF   = SQRT(SUM OF (DD(I)-DDOLD(I))**2)
C     TOTAL  = SQRT(SUM OF DDOLD(I)**2)
C     DDOLD  = NODAL PARAMETER LIST FROM LAST ITERATION
C     DD     = NODAL PARAMETERS FROM CURRENT ITERATION
C     NDFREE = TOTAL NO OF DEGREES OF FREEDOM IN SYS
C     IPRINT > 0, PRINT DIFF, TOTAL, AND RATIO
CDP   SQRT(Z) = DSQRT(Z)
      DIFF  = 0.0
      TOTAL = 0.1E-10
      DO 10  I = 1, NDFREE
        TOTAL = TOTAL + DDOLD(I)*DDOLD(I)
   10 DIFF = DIFF + (DD(I)-DDOLD(I))**2
      TOTAL = SQRT(TOTAL)
      DIFF  = SQRT(DIFF)
      RATIO = DIFF/TOTAL
      IF ( IPRINT .EQ. 0 )  RETURN
      WRITE (NPRT,5000)  DIFF, TOTAL, RATIO
 5000 FORMAT ( 
     1 '*** NODAL DOF FOR CURRENT AND PREVIOUS ITERATIONS ***',/,
     2 'ROOT MEAN SQ OF DIFFERENCES . . . . . ',1PE13.5,/,
     3 'ROOT MEAN SQ OF PREVIOUS VALUES . . . ',1PE13.5,/,
     4 'RATIO OF ABOVE QUANTITIES . . . . . . ',1PE13.5)
      RETURN
      END

      SUBROUTINE  CHKSHP (N, NSPACE, LSHAPE, LBN)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C      CHECK LSHAPE DATA FOR FREQUENT USER ERRORS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER (NPRT = 6 )
C       FORCE THE INPUT VALUE IF NEGATIVE
      IF ( LSHAPE .LT. 0 )  THEN
        LSHAPE = IABS( LSHAPE )
        RETURN
      ENDIF
C       LINE
      IF ( N .EQ. 2 .AND. LSHAPE .NE. 1) THEN
        LSHAPE = 1
        WRITE(NPRT,1000) LSHAPE
 1000   FORMAT ('********************************',/,
     1          '* WARNING LSHAPE CHANGED TO', I2, ' *', /,
     2          '********************************')
      ENDIF
C       TRIANGLE
      IF ( NSPACE .GT. 1 .AND. N .EQ. 3 .AND. LSHAPE .NE. 2) THEN
        LSHAPE = 2
        WRITE(NPRT,1000) LSHAPE
      ENDIF
C      QUADRILATERAL
      IF ( NSPACE .GT. 1 .AND. N .EQ. 4 .AND. LSHAPE .NE. 3) THEN
        LSHAPE = 3
        WRITE(NPRT,1000) LSHAPE
      ENDIF
C       TRI OR WEDGE
      IF ( N .EQ. 6 .AND. LSHAPE .NE. 2) THEN
        IF ( NSPACE .EQ. 2 ) THEN
          LSHAPE = 2
          WRITE(NPRT,1000) LSHAPE
        ENDIF
      ENDIF
C       QUAD OR HEX
      IF ( N .EQ. 8 .AND. LSHAPE .NE. 3) THEN
        IF ( NSPACE .EQ. 3 )  THEN
          LSHAPE = 3
          WRITE(NPRT,1000) LSHAPE
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE  CONDSE (NTOTAL, NELFRE, S, C)
C     * * * * * * * * * * * * * * * * * * * * * * *
C     CONDENSATION OF ELEMENT MATRICES TO REMOVE
C                INTERNAL DEGREES OF FREEDOM
C     * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( ZERO = 0.0 )
      DIMENSION  S(NTOTAL,NTOTAL), C(NTOTAL)
C     INTERNAL DEGREES OF FREEDOM *MUST* COME LAST
C        :  SAA : SAB  : : DA :     : CA :
C        :......:......: :....:  =  :....:
C        :  SBA : SBB  : : DB :     : CB :
C     ENTER FULL S ; RETURN CONDENSED IN SAA AND CA
C     DIMENSION  SAA(NELFRE,NELFRE), CA(NELFRE)
C     SAA* = (SAA) - (SAB)*(SBB)I*(SAB)T
C     CA*  = (CA) - (SAB)*(SBB)I*(CB)
C     NTOTAL = ORIG. NO. OF D.O.F. OF ELEMENT
C     NELFRE = FINAL NO. OF D.O.F. OF ELEMENT
C     NELIM  = NUMBER OF DOF TO ELIMINATE
C     S      = SQUARE ELEMENT MATRIX
C          C = ELEMENT COLUMN MATRIX
      NELIM = NTOTAL - NELFRE
      DO 30  I = 1, NELIM
        J = NTOTAL - I
        K = J + 1
        SKK = S(K,K)
        CK  = C(K)
        IF ( SKK .NE. ZERO )  THEN
          C(K) = CK/SKK
          DO 20  L = 1, J
            SLKSKK = S(L,K)/SKK
            S(L,K) = SLKSKK
            DO 10  M = L, J
              S(L,M) = S(L,M) - S(K,M)*SLKSKK
 10         S(M,L) = S(L,M)
            C(L) = C(L) - CK*SLKSKK
 20       CONTINUE
        ENDIF
 30   CONTINUE
      RETURN
      END
      SUBROUTINE CONTROL (TITLE, M, NE, NG, N, NSPACE, NSEG, LBN, 
     1           NITER, NCURVE, INRHS, ISAY, NNPFIX, NNPFLO, NLPFIX, 
     2           NLPFLO, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, 
     3           NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, 
     4           NDFREE, NELFRE, NFLUX, IPTEST, LPTEST, NRB, NQP, 
     5           LSHAPE, NLTYPE, MODE, IBUG, NBSFIX, NBSFLO, NGF)
C        1         2         3         4         5         6         712
C23456789012345678901234567890123456789012345678901234567890-----------X
      DIMENSION  TITLE(15)
C          PRINT AUTHOR CREDITS
C     CALL  TOOT
C-->    ** READ AND PRINT TITLE AND CONTROL DATA **
      NTAPE3 = 0
      NTAPE4 = 0
      NTAPE5 = 0
      READ  (5,1234)   TITLE
      WRITE (6,1234)   TITLE
 1234 FORMAT ( 15A4 )
      READ  (5,5020) M,      NE,     NG,     N, 
     1               NSPACE, NSEG,   LBN,    NITER, 
     2               NCURVE, INRHS,  ISAY,   NRB, 
     3               NQP,    LSHAPE, NLTYPE, MODE
 5020 FORMAT ( 16I5 )
C      CHECK FOR EXTRA OUTPUT REQUESTS
      IBUG = 0
      IF ( NITER .LT. 0 )  THEN
        IBUG  = 1
        NITER = IABS ( NITER )
      ENDIF
      IF ( LSHAPE .LT. 1 )  LSHAPE = 1
      IF ( N      .LT. 1 )  N      = 2
      IF ( NG     .LT. 1 )  NG     = 1
      IF ( NITER  .LT. 1 )  NITER  = 1
      IF ( NLTYPE .LT. 1 )  NLTYPE = 1
      IF ( NRB    .LT. 1 )  NRB    = 1
      IF ( NSPACE .LT. 1 )  NSPACE = 1
C      CHECK ELEMENT SHAPE DATA
      CALL CHKSHP (N, NSPACE, LSHAPE, LBN)
      MODE = 1
      IF ( NITER .LT. 1 )  NITER = 1
      WRITE (6,5030) M, NE, NG, N, NSPACE, NSEG, LBN, 
     1               NITER, NCURVE, INRHS, ISAY, NRB, NQP, 
     2               LSHAPE, NLTYPE, MODE
 5030 FORMAT (/,'****  PROBLEM PARAMETERS (DEFAULT) ****',/,
     1 'NUMBER OF NODAL POINTS IN SYSTEM ............',I5,/,
     2 'NUMBER OF ELEMENTS IN SYSTEM ................',I5,/,
     4 'NUMBER OF PARAMETERS PER NODE (1)............',I5,/,
     3 'NUMBER OF NODES PER ELEMENT (2)..............',I5,/,
     5 'DIMENSION OF SPACE (1).......................',I5,/,
     6 'NUMBER OF BOUNDARIES WITH GIVEN FLUX ........',I5,/,
     7 'NUMBER OF NODES ON BOUNDARY SEGMENT .........',I5,/,
     8 'NUMBER OF ITERATIONS TO BE RUN (1)...........',I5,/,
     9 'NUMBER OF CONTOURS BETWEEN 5 & 95% ..........',I5,/,
     + 'INITIAL FORCING VECTOR (0-OMIT, 1-READ)......',I5,/,
     1 'NUMBER OF USER REMARKS LINES ................',I5,/,
     2 'NUMBER OF ROWS IN B MATRIX (1)...............',I5,/,
     3 'NUMBER OF QUADRATURE POINTS .................',I5,/,
     4 'SHAPE 1-LINE 2-TRI 3-QUAD 4-HEX 5-TET (1)....',I5,/,
     5 'NUMBER OF DIFFERENT ELEMENT TYPES (1)........',I5,/,
     6 'STIFFNESS STORAGE MODE: (0-SKY, 1-BAND)......',I5)
      READ (5,5070) NNPFIX, NNPFLO, NLPFIX, NLPFLO, 
     1              MISCFX, MISCFL, NHOMO,  LHOMO,  
     2              NPTWRT, LEMWRT, NTAPE1, NTAPE2, 
     3              NGF,    NULCOL, NBSFIX, NBSFLO
 5070 FORMAT ( 16I5 )
      IF ( NSEG .GT. 0 .AND. NGF .LT. 1 )  THEN
        WRITE (6,*) 'WARNING, NGF < 1, SET TO NGF = NG'
        NGF = NG
      ENDIF
      WRITE (6,5080)  NGF,    NNPFIX, NNPFLO, NLPFIX, NLPFLO, 
     1                NBSFIX, NBSFLO, MISCFX, MISCFL
 5080 FORMAT (
     8 'NUMBER OF FLUX COMPONENTS PER NODE (NG)......',I5,/,
     1 'NUMBER OF INTEGER PROPERTIES PER NODE .......',I5,/,
     2 'NUMBER OF REAL PROPERTIES PER NODE ..........',I5,/,
     3 'NUMBER OF INTEGER PROPERTIES PER ELEMENT ....',I5,/,
     4 'NUMBER OF REAL PROPERTIES PER ELEMENT .......',I5,/,
     3 'NUMBER OF INTEGER PROPERTIES PER SEGMENT ....',I5,/,
     4 'NUMBER OF REAL PROPERTIES PER SEGMENT .......',I5,/,
     5 'NUMBER OF INTEGER MISCELLANEOUS  PROPERTIES .',I5,/,
     6 'NUMBER OF REAL MISCELLANEOUS  PROPERTIES ....',I5)
      IF ( LBN .GT. N )    
     1     STOP  'INCONSISTANT VALUES OF LBN AND N.'
      NELFRE = N*NG
      NDFREE = M*NG
      NFLUX  = LBN*NG
      WRITE (6,5081) NELFRE, NFLUX, NDFREE
 5081 FORMAT (
     1 'NUMBER OF D.O.F. FOR ELEMENT ................',I5,/,
     2 'NUMBER OF D.O.F. ON FLUX SEGMENT ............',I5,/,
     3 'NUMBER OF D.O.F. IN TOTAL SYSTEM ............',I5)
      IF ( NHOMO .EQ. 1 )  WRITE (6,*)
     1    'NODAL POINT PROPERTIES ARE HOMOGENEOUS.'
      IF ( LHOMO .EQ. 1 )  WRITE (6,*)
     1    'ELEMENT PROPERTIES ARE HOMOGENEOUS.'
      NSUM = NTAPE1 + NTAPE2 + NTAPE3 + NTAPE4 + NTAPE5
      IF ( NSUM .GT. 0 )  WRITE (6,5180)  
     1               NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5
 5180 FORMAT ( /, 'OPTIONAL UNIT NUMBERS (UTILIZED IF > 0)',/,
     1 'NTAPE1 = ',I2,', NTAPE2 = ',I2,/,'NTAPE3 = ',I2,
     2 ', NTAPE4 = ',I2,', NTAPE5 = ',I2)
      IF ( NPTWRT .EQ. 0 )  WRITE (6,*)
     1    'NODAL PARAMETERS TO BE LISTED BY NODES'
      IF ( LEMWRT .EQ. 0 )  WRITE (6,*)
     1    'NODAL PARAMETERS TO BE LISTED BY ELEMENTS'
      IF ( NULCOL .NE. 0 )  WRITE (6,*)
     1    'ALL ELEMENT COLUMN MATRICES ARE ZERO.'
      IF ( NTAPE1 .GT. 0 )  REWIND NTAPE1
      IF ( NTAPE2 .GT. 0 )  REWIND NTAPE2
      IF ( NTAPE3 .GT. 0 )  REWIND NTAPE3
      IF ( NTAPE4 .GT. 0 )  REWIND NTAPE4
      IF ( NTAPE5 .GT. 0 )  REWIND NTAPE5
      IF ( ISAY   .GT. 0 )  CALL  IREMRK (ISAY)
C        SET INITIAL CONSTANTS
C     LPTEST > 0, ELEMENT PROPERTIES ARE DEFINED
C     IPTEST > 0, SOME PROPERTIES ARE DEFINED
C     NBSFIX = NUMBER OF FIXED PT SEGMENT PROP
C     NBSFLO = NUMBER OF FLOATING PT SEGMENT PROP
C     NLPFIX = NUMBER OF FIXED PT ELEMENT PROP
C     NLPFLO = NUMBER OF FLOATING PT ELEMENT PROP
C     NNPFIX = NUMBER OF FIXED PT NUMBER PROP
C     NNPFLO = NUMBER OF FLOATING PT NUMBER PROP
C     MISCFL = NUMBER OF MISC FLOATING PT SYSTEM PROP
C     MISCFX = NUMBER OF MISC FIXED  PT SYSTEM PROP
C     MAXTYP = MAX ALLOWED CONSTRAINT TYPE
C     RATIO  = CONSTANT FOR ITER CONTROL, SEE MODEL
      RATIO  = 1.0
C     MAXTYP = 5
C     IF ( NFLUX .LT. 1 ) NFLUX = 1
      IPTEST = NNPFIX + NNPFLO + NLPFIX + NLPFLO 
     1       + NBSFIX + NBSFLO + MISCFX + MISCFL
      LPTEST = NLPFIX + NLPFLO
      RETURN
      END
      SUBROUTINE  CORECT (NDFREE, DD, DDOLD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CALCULATE NEW STARTING VALUES FOR NEXT ITERATION
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        OVER RELAXATION METHOD
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  DD(NDFREE),  DDOLD(NDFREE)
      PARAMETER  ( OMEGA = 1.25 )
C     DD     = CALCULATED DOF FROM LAST ITERATION
C     DDOLD  = DOF TO BE USED TO START NEXT ITERATION
C     NDFREE = TOTAL NO OF SYS DEGREES OF FREEDOM
      DO 10  I = 1,NDFREE
 10   DDOLD(I) = DDOLD(I) + OMEGA*(DD(I)-DDOLD(I))
      RETURN
      END
      SUBROUTINE  DCHECK (DELTA,N,NSPACE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CHECKING OF THE LOCAL COORDINATE DERIVATIVES OF THE
C     N SHAPE FUNCTIONS AT A LOCAL POINT FOR A C0 ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DOUBLE PRECISION  ONE, SUM, TOL
      PARAMETER  ( ONE = 1.0D0, TOL = 1.0D-7, NPRT = 6 )
      DIMENSION  DELTA(NSPACE,N)
C     DELTA  = LOCAL DERIVATIVES OF SHAPE FUNCTIONS
C     N      = NUMBER OF SHAPE FUNCTIONS
C     NSPACE = DIMENSION OF LOCAL SPACE
      IERR = 0
      DO 20  J = 1,NSPACE
        SUM = 0.D0
        DO 10  I = 1,N
   10   SUM = SUM + DELTA(J,I)
        IF ( ABS(SUM) .GT. TOL )  THEN
          IF ( IERR .EQ. 0 )  WRITE (NPRT,*) 
     &         'SUPPLIED DERIVATIVES ARE INCORRECT'
          IERR = 1          
          WRITE (NPRT,*) 'J, SUM', J, SUM
        ENDIF
   20 CONTINUE
      IF ( IERR .NE. 0 )  THEN
        CALL RPRINT (DELTA,N,NSPACE,1)
        WRITE (NPRT,*) 'END OF WARNING FROM DCHECK'
      ENDIF
      RETURN
      END
      SUBROUTINE  DEGPAR (IPT, JPARM, NG, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * *
C      DETERMINE THE DEGREE OF FREEDOM NUMBER
C      OF NODAL PARAMETER JPARM AT NODE POINT IPT
C     * * * * * * * * * * * * * * * * * * * * * * *
C     NG = NUMBER OF PARAMETERS PER NODE
      INDEX = NG*(IPT-1) + JPARM
      RETURN
      END
      SUBROUTINE  DELAST (IOPT, E, PR, T, D, NS)
C     * * * * * * * * * * * * * * * * * * * * * * *
C     CONSTITUTIVE MATRIX, ELASTICITY  (D)
C     * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  D(NS,NS)
C     D    = CONSTITUTIVE MATRIX
C     E    = MODULUS OF ELASTICITY
C     IOPT = ELASTICITY CLASS
C          = 1, AXIAL BAR,    T = AREA
C          = 2, PLANE STRESS, T = THICKNESS
C          = 3, PLANE STRAIN, T = THICKNESS
C          = 4, AXISYMMETRIC
C          = 5, 3-D SOLID
C     NS   = NUMBER OF STRAINS (ROWS IN B-MATRIX)
C     PR   = POISSON'S RATIO
C     T    = AREA, OR THICKNESS
      IF ( T.LE.0.0 ) T = 1.0
      IF ( IOPT.LT.1 .OR. IOPT.GT.5 )  STOP 'DELAST'
      IF ( IOPT.NE.1 )  GO TO 20
C        1-D, SXX
        D(1,1) = E*T
        RETURN
 20   IF ( IOPT.NE.2 )  GO TO 30
C        PLANE STRESS ONLY, SXX, SYY, SXY
        C      = T*E/(1.-PR*PR)
        D(1,1) = C
        D(2,1) = C*PR
        D(3,1) = 0.0
        D(1,2) = C*PR
        D(2,2) = C
        D(3,2) = 0.0
        D(1,3) = 0.0
        D(2,3) = 0.0
        D(3,3) = 0.5*T*E/(1.+PR)
        RETURN
 30   CONTINUE
C        PLANE STRAIN OR 3-D, SXX, SYY, SXY
        C        = E*(1.-PR)/(1.+PR)/(1.-PR-PR)
        C2     = C*PR/(1.-PR)
        G        = 0.5*E/(1.+PR)
        D(1,1) = C
        D(2,1) = C2
        D(3,1) = 0.0
        D(1,2) = C2
        D(2,2) = C
        D(3,2) = 0.0
        D(1,3) = 0.0
        D(2,3) = 0.0
        D(3,3) = G
      IF ( IOPT.EQ.3 ) RETURN
C        AXISYMMETRIC ONLY, SXX, SYY, SXY, STT
        D(4,1) = C2
        D(4,2) = C2
        D(4,3) = 0.0
        D(1,4) = C2
        D(2,4) = C2
        D(3,4) = 0.0
        D(4,4) = C
      IF ( IOPT.NE.5 )  RETURN
C       3-D SOLID ONLY, SXX, SYY, SXY, SZZ, SXZ, SYZ
        D(5,1) = 0.0
        D(6,1) = 0.0
        D(5,2) = 0.0
        D(6,2) = 0.0
        D(5,3) = 0.0
        D(6,3) = 0.0
        D(5,4) = 0.0
        D(6,4) = 0.0
        D(1,5) = 0.0
        D(2,5) = 0.0
        D(3,5) = 0.0
        D(4,5) = 0.0
        D(5,5) = G
        D(6,5) = 0.0
        D(1,6) = 0.0
        D(2,6) = 0.0
        D(3,6) = 0.0
        D(4,6) = 0.0
        D(5,6) = 0.0
        D(6,6) = G
      RETURN
      END
      SUBROUTINE  DER16QS (R,S,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C     LOCAL DERIVATIVES FOR A SERENDIPITY 16 NODE QUAD
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
      PARAMETER  ( PT667 = 0.66666666666667 ,PT1D12 = 0.083333333333333
     1            ,HALF = 0.5)      
C     SEE SHP16QS FOR NODE LOCATIONS
      DIMENSION  DH(2,16)
      RR = R*R
      SS = S*S
      RRR = R*R*R
      SSS = S*S*S
      RP = 1. + R
      RM = 1. - R
      R1 = R - 1.
      SP = 1. + S
      SM = 1. - S
      DH(1,1) = PT1D12*SM*(16.*RRR - 12.*RR - 2.*R + 4.*SSS - S + 4.)  
      DH(1,2) = PT1D12*SM*(16.*RRR + 12.*RR - 2.*R - 4.*SSS + S - 4.)
      DH(1,3) = PT1D12*SP*(16.*RRR + 12.*RR - 2.*R + 4.*SSS - S - 4.)
      DH(1,4) = PT1D12*SP*(16.*RRR - 12.*RR - 2.*R - 4.*SSS + S + 4.)
      DH(1,5) = PT667*(4.*R - 1. + 3.*RR - 8.*RRR)*SM
      DH(1,6) = PT667*S*SM*SP*( -1. + 2.*S)
      DH(1,7) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SP
      DH(1,8) = -PT667*S*SM*SP*(1. + 2.*S)
      DH(1,9) = R*(-5. + 8.*RR)*SM
      DH(1,10) = HALF*SM*SP*(1. - 2.*S)*(1. + 2.*S)
      DH(1,11) = R*( -5. + 8.*RR)*SP
      DH(1,12) = HALF*SM*SP*( -1. + 2.*S)*(1. + 2.*S)
      DH(1,13) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SM
      DH(1,14) = PT667*S*SM*SP*(1. + 2.*S)
      DH(1,15) = PT667*(4.*R - 1. + 3.*RR - 8.*RRR)*SP
      DH(1,16) = PT667*S*SM*SP*(1. - 2.*S)
      DH(2,1) = PT1D12*RM*(16.*SSS - 12.*SS - 2.*S + 4.*RRR - R + 4.)
      DH(2,2) = PT1D12*RP*(16.*SSS - 12.*SS - 2.*S - 4.*RRR + R + 4.)
      DH(2,3) = PT1D12*RP*(16.*SSS + 12.*SS - 2.*S + 4.*RRR - R - 4.)
      DH(2,4) = PT1D12*R1*(-16.*SSS - 12.*SS + 2.*S + 4.*RRR - R + 4.)
      DH(2,5) = PT667*R*R1*RP*(2.*R - 1.)
      DH(2,6) = PT667*( -1. + 4.*S + 3.*SS - 8.*SSS)*RP
      DH(2,7) = PT667*R*RM*RP*(1. + 2.*R)
      DH(2,8) = PT667*( -1. - 4.*S + 3.*SS + 8.*SSS)*R1
      DH(2,9) = HALF*RM*RP*(2.*R - 1.)*(1. + 2.*R)
      DH(2,10) = S*( -5. + 8.*SS)*RP
      DH(2,11) = HALF*R1*RP*(2.*R - 1.)*(1. + 2.*R)
      DH(2,12) = S*(5. - 8.*SS)*R1
      DH(2,13) = PT667*R*R1*RP*(1. + 2.*R)
      DH(2,14) = PT667*(1. + 4.*S - 3.*SS - 8.*SSS)*RP
      DH(2,15) = PT667*R*RM*RP*(2.*R - 1.)
      DH(2,16) = PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*R1
      RETURN
      END
      SUBROUTINE  DER16R  (R,S,A,B,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C           FIRST DERIVATIVES OF A
C     C1 RECTANGULAR ELEMENT IN UNIT COORDINATES
C       USING TENSOR PRODUCTS OF 1D BASIS
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  DH(2,16), HR(4), DHR(4), HS(4), DHS(4)
C     DOF ARE W W,X W,Y W,XY AT EACH NODE (NG=4)
C     X // R, Y // S.              S
C     A = PHYSICAL LENGTH IN X     4 -------- 3
C     B = PHYSICAL LENGTH IN Y     I          I
C     R,S = LOCAL UNIT COORDS      I          I
C     1@(0,0), 3@(1,1)             1 -------- 2 ->R
C
C     Evaluate the 1D interpolations
      CALL  SHPC1L (R,A,HR)
      CALL  SHPC1L (S,B,HS)
      CALL  DERC1L (R,A,DHR)
      CALL  DERC1L (S,B,DHS)
C     Form tensor products for R direction
      DH(1,1) = DHR(1)*HS(1)
      DH(1,2) = DHR(2)*HS(1)
      DH(1,3) = DHR(1)*HS(2)
      DH(1,4) = DHR(2)*HS(2)
      DH(1,5) = DHR(3)*HS(1)
      DH(1,6) = DHR(4)*HS(1)
      DH(1,7) = DHR(3)*HS(2)
      DH(1,8) = DHR(4)*HS(2)
      DH(1,9) = DHR(3)*HS(3)
      DH(1,10) = DHR(4)*HS(3)
      DH(1,11) = DHR(3)*HS(4)
      DH(1,12) = DHR(4)*HS(4)
      DH(1,13) = DHR(1)*HS(3)
      DH(1,14) = DHR(2)*HS(3)
      DH(1,15) = DHR(1)*HS(4)
      DH(1,16) = DHR(2)*HS(4)
C     Form tensor products for S direction
      DH(2,1) = HR(1)*DHS(1)
      DH(2,2) = HR(2)*DHS(1)
      DH(2,3) = HR(1)*DHS(2)
      DH(2,4) = HR(2)*DHS(2)
      DH(2,5) = HR(3)*DHS(1)
      DH(2,6) = HR(4)*DHS(1)
      DH(2,7) = HR(3)*DHS(2)
      DH(2,8) = HR(4)*DHS(2)
      DH(2,9) = HR(3)*DHS(3)
      DH(2,10) = HR(4)*DHS(3)
      DH(2,11) = HR(3)*DHS(4)
      DH(2,12) = HR(4)*DHS(4)
      DH(2,13) = HR(1)*DHS(3)
      DH(2,14) = HR(2)*DHS(3)
      DH(2,15) = HR(1)*DHS(4)
      DH(2,16) = HR(2)*DHS(4)
      RETURN
      END
      SUBROUTINE  DER17Q (R,S,DH)
C     ******************************************************************
C     LOCAL DERIVATIVES OF SERENDIPITY QUAD WITH 17 NODES
C     ******************************************************************
      PARAMETER  ( PT667 = 0.66666666666667 ,PT1D12 = 0.083333333333333 
     1            ,HALF = 0.5)      
C     SEE SHP17Q FOR NODE LOCATIONS
      DIMENSION  DH(2,17)
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      R1 = R - 1.
      RR = R*R
      SS = S*S
      RRR = R*R*R
      SSS = S*S*S
      DH(1,1) = PT1D12*SM*(16.*RRR-12.*RR-6.*R*S-8.*R+4.*SSS-S+4.)
      DH(1,2) = PT1D12*SM*(16.*RRR+12.*RR-6.*R*S-8.*R-4.*SSS+S-4.)
      DH(1,3) = PT1D12*SP*(16.*RRR+12.*RR+6.*R*S-8.*R+4.*SSS-S-4.)
      DH(1,4) = PT1D12*SP*(16.*RRR-12.*RR+6.*R*S-8.*R-4.*SSS+S+4.)
      DH(1,5) = -PT667*(1. - 4.*R - 3.*RR + 8.*RRR)*SM
      DH(1,6) = PT667*S*SM*SP*( -1. + 2.*S)
      DH(1,7) = -PT667*(-1. - 4.*R + 3.*RR + 8.*RRR)*SP
      DH(1,8) = -PT667*S*SM*SP*(1. + 2.*S)
      DH(1,9) = R*SM*(8.*RR + S - 4.)
      DH(1,10) = HALF*SM*SP*(2.*R - 4.*SS + 1.)
      DH(1,11) = R*SP*(8.*RR - S - 4.)
      DH(1,12) = HALF*SM*SP*(2.*R - 1. + 4.*SS)
      DH(1,13) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SM
      DH(1,14) = PT667*S*SM*SP*(1. + 2.*S)
      DH(1,15) = -PT667*(1. - 4.*R - 3.*RR + 8.*RRR)*SP
      DH(1,16) = PT667*S*SM*SP*(1. - 2.*S)
      DH(1,17) = -2.*R*SM*SP
      DH(2,1) = PT1D12*RM*(16.*SSS-12.*SS-6.*R*S-8.*S+4.*RRR-R+4.)
      DH(2,2) = -PT1D12*RP*(-16.*SSS+12.*SS-6.*R*S+8.*S+4.*RRR-R-4.)
      DH(2,3) = PT1D12*RP*(16.*SSS+12.*SS+6.*R*S-8.*S+4.*RRR-R-4.)
      DH(2,4) = PT1D12*R1*(-16.*SSS-12.*SS+6.*R*S+8.*S+4.*RRR-R+4.)
      DH(2,5) = PT667*R*R1*RP*(2.*R - 1.)
      DH(2,6) = -PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*RP
      DH(2,7) = -PT667*R*R1*RP*(1. + 2.*R)
      DH(2,8) = PT667*(-1. - 4.*S + 3.*SS + 8.*SSS)*R1
      DH(2,9) = -HALF*R1*RP*(2.*S - 1. + 4.*RR)
      DH(2,10) = -S*RP*(-8.*SS + R + 4.)
      DH(2,11) = HALF*R1*RP*( -2.*S + 4.*RR - 1.)
      DH(2,12) = -S*R1*(8.*SS + R - 4.)
      DH(2,13) = PT667*R*R1*RP*(1. + 2.*R)
      DH(2,14) = -PT667*( -1. - 4.*S + 3.*SS + 8.*SSS)*RP
      DH(2,15) = -PT667*R*R1*RP*(2.*R - 1.)
      DH(2,16) = PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*R1
      DH(2,17) = 2.*S*R1*RP
      RETURN
      END
      SUBROUTINE  DER208 (R, S, T, DH, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C       LOCAL DERIVATIVES OF INTERPOLATION FUNCTIONS FOR AN
C     8 TO 20 NODE HEXAHEDRON, SEE SHP208 FOR TOPOLOGY FIGURE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CIBM  IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(3,20), LNODE(20), I1(20), I2(20)
      DATA I1 /8*0, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4/
      DATA I2 /8*0, 2, 3, 4, 1, 6, 7, 8, 5, 5, 6, 7, 8/
      DATA FP, FM / 0.5, -0.5 /
C     FOR PARAMETER DEFINITIONS SEE SUBROUTINE SHP208
C     R,S,T = LOCAL COORDINATES OF THE POINT   -1 LE (R,S,T) LE +1
C     DH    = LOCAL DERIVATIVES OF SHAPE FUNCTIONS, 0 IF LNODE(I) = 0
C     LNODE = ARRAY OF ELEMENT INCIDENCES,  
C         IF LNODE(I)=0 THEN LOCAL NODE I IS NOT CONSIDERED IN ANALYSIS
C     I1, I2 = CORNER NODES OF TWELVE EDGES
      RP = 0.5*(1. + R)
      SP = 0.5*(1. + S)
      TP = 0.5*(1. + T)
      RM = 0.5*(1. - R)
      SM = 0.5*(1. - S)
      TM = 0.5*(1. - T)
      RZ = 1. - R*R
      SZ = 1. - S*S
      TZ = 1. - T*T
      FR = -2.0*R
      FS = -2.0*S
      FT = -2.0*T
C      DERIVATIVES OF TRI-LINEAR CORNERS
      DH(1,1 ) = TP*SP*FP
      DH(2,1 ) = TP*FP*RP
      DH(3,1 ) = FP*SP*RP
      DH(1,2 ) = TP*SP*FM
      DH(2,2 ) = TP*FP*RM
      DH(3,2 ) = FP*SP*RM
      DH(1,3 ) = TP*SM*FM
      DH(2,3 ) = TP*FM*RM
      DH(3,3 ) = FP*SM*RM
      DH(1,4 ) = TP*SM*FP
      DH(2,4 ) = TP*FM*RP
      DH(3,4 ) = FP*SM*RP
      DH(1,5 ) = TM*SP*FP
      DH(2,5 ) = TM*FP*RP
      DH(3,5 ) = FM*SP*RP
      DH(1,6 ) = TM*SP*FM
      DH(2,6 ) = TM*FP*RM
      DH(3,6 ) = FM*SP*RM
      DH(1,7 ) = TM*SM*FM
      DH(2,7 ) = TM*FM*RM
      DH(3,7 ) = FM*SM*RM
      DH(1,8 ) = TM*SM*FP
      DH(2,8 ) = TM*FM*RP
      DH(3,8 ) = FM*SM*RP
C      DERIVATIVES OF EDGE BUBBLES
      DH(1,9 ) = TP*SP*FR*0.5
      DH(2,9 ) = TP*FP*RZ*0.5
      DH(3,9 ) = FP*SP*RZ*0.5
      DH(1,10) = TP*SZ*FM*0.5
      DH(2,10) = TP*FS*RM*0.5
      DH(3,10) = FP*SZ*RM*0.5
      DH(1,11) = TP*SM*FR*0.5
      DH(2,11) = TP*FM*RZ*0.5
      DH(3,11) = FP*SM*RZ*0.5
      DH(1,12) = TP*SZ*FP*0.5
      DH(2,12) = TP*FS*RP*0.5
      DH(3,12) = FP*SZ*RP*0.5
      DH(1,13) = TM*SP*FR*0.5
      DH(2,13) = TM*FP*RZ*0.5
      DH(3,13) = FM*SP*RZ*0.5
      DH(1,14) = TM*SZ*FM*0.5
      DH(2,14) = TM*FS*RM*0.5
      DH(3,14) = FM*SZ*RM*0.5
      DH(1,15) = TM*SM*FR*0.5
      DH(2,15) = TM*FM*RZ*0.5
      DH(3,15) = FM*SM*RZ*0.5
      DH(1,16) = TM*SZ*FP*0.5
      DH(2,16) = TM*FS*RP*0.5
      DH(3,16) = FM*SZ*RP*0.5
      DH(1,17) = TZ*SP*FP*0.5
      DH(2,17) = TZ*FP*RP*0.5
      DH(3,17) = FT*SP*RP*0.5
      DH(1,18) = TZ*SP*FM*0.5
      DH(2,18) = TZ*FP*RM*0.5
      DH(3,18) = FT*SP*RM*0.5
      DH(1,19) = TZ*SM*FM*0.5
      DH(2,19) = TZ*FM*RM*0.5
      DH(3,19) = FT*SM*RM*0.5
      DH(1,20) = TZ*SM*FP*0.5
      DH(2,20) = TZ*FM*RP*0.5
      DH(3,20) = FT*SM*RP*0.5
C      LOOP OVER TWELVE EDGES
      DO 20  K = 9,20
        IF ( LNODE(K) .EQ. 0 )  THEN
C          ZERO EDGE BUBBLE DERIVATIVES
          DH(1,K) = 0.0
          DH(2,K) = 0.0
          DH(3,K) = 0.0
        ELSE
C          ENRICH DERIVATIVES AT TWO ENDS OF EDGE
          DH1 = DH(1,K)
          DH2 = DH(2,K)
          DH3 = DH(3,K)
          K1  = I1(K)
          K2  = I2(K)
          DH(1,K1) = DH(1,K1) - DH1
          DH(2,K1) = DH(2,K1) - DH2
          DH(3,K1) = DH(3,K1) - DH3
          DH(1,K2) = DH(1,K2) - DH1
          DH(2,K2) = DH(2,K2) - DH2
          DH(3,K2) = DH(3,K2) - DH3
          DH(1,K) = DH1 + DH1
          DH(2,K) = DH2 + DH2
          DH(3,K) = DH3 + DH3
        ENDIF   
   20 CONTINUE
      RETURN
      END
      SUBROUTINE  DER2CU (B, A, D2H)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     SECOND DERIVATIVES OF SHAPE FUNCTIONS FOR 1-D
C      CUBIC HERMITE ELEMENT   (A C1 ELEMENT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  D2H(4)
C     A  = LENGTH OF ELEMENT (SEE SUBR SHPCU)
C     B  = COORDINATE OF POINT
C     D2H = SECOND DERIVATIVES OF H
      D2H(1) = (12.*B - 6.)/A/A
      D2H(2) = (6.*B - 4.)/A
      D2H(3) = (6. - 12.*B)/A/A
      D2H(4) = (6.*B - 2.)/A
      RETURN
      END
      SUBROUTINE  DER2L (R,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     DERIVATIVES OF A 2 NODE LINE ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION DH(2)
C     R IS UNIT COORD.   R=-1  1------------2  R=1
      DH(1) = -0.5
      DH(2) = 0.5
      RETURN
      END
      SUBROUTINE  DER3L (X, DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND LOCAL DERIVATIVES FOR A 3 NODE LINE ELEMENT
C                 IN NATURAL COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(3)
C     DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS (SHP3L)
C     X  = LOCAL COORDINATE OF POINT,    -1 TO +1
C     LOCAL NODE COORD. ARE -1,0,+1.   1----2----3
      DH(1) = X - 0.5
      DH(2) = -2.*X
      DH(3) = X + 0.5
      RETURN
      END
      SUBROUTINE  DER3T (S, T, DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOCAL DERIVATIVES OF A THREE NODE UNIT TRIANGLE
C                SEE SUBROUTINE SHP3T 
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(2,3)
C     S,T     = LOCAL COORDINATES OF THE POINT
C     DH(1,K) = DH(K)/DS
C     DH(2,K) = DH(K)/DT
C     NODAL COORDS ARE :  1-(0,0) 2-(1,0) 3-(0,1)
      DH(1,1) = -1.
      DH(1,2) = 1.
      DH(1,3) = 0.0
      DH(2,1) = -1.
      DH(2,2) = 0.0
      DH(2,3) = 1.
      RETURN
      END
      SUBROUTINE  DER4Q (R, S, DELTA)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOCAL DERIVATIVES OF THE SHAPE FUNCTIONS FOR AN
C     ISOPARAMETRIC QUADRILATERAL WITH FOUR NODES
C                SEE SHP4Q
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DELTA(2,4)
C     DELTA(1,I) = DH/DR 
C     DELTA(2,I) = DH/DS
C     H          = LOCAL INTERPOLATION FUNCTIONS
C     (R,S)      = A POINT IN THE LOCAL COORDINATES
C     HERE D(H(I))/DR = 0.25*R(I)*(1+S*S(I)), ETC.
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      DELTA(1,1) = -0.25*SM
      DELTA(1,2) =  0.25*SM
      DELTA(1,3) =  0.25*SP
      DELTA(1,4) = -0.25*SP
      DELTA(2,1) = -0.25*RM
      DELTA(2,2) = -0.25*RP
      DELTA(2,3) =  0.25*RP
      DELTA(2,4) =  0.25*RM
      RETURN
      END
      SUBROUTINE  DER6T (S,T,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOCAL DERIVATIVES FOR A SIX NODE UNIT TRIANGLE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(2,6)
C     S,T = LOCAL COORDINATES, SEE SHP6T
C     DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS
C     DH(1,K) = DH(K)/DS,   DH(2,K)=DH(K)/DT
C     NODAL COORDS : 1-(0,0)   2-(1,0)   3-(0,1)
C                    4-(0.5,0)  5-(0.5,0.5)  6-(0,0.5)
      DH(1,1) = -3. + 4.*S + 4.*T
      DH(1,2) = -1. + 4.*S
      DH(1,3) = 0.0
      DH(1,4) = 4. - 8.*S - 4.*T
      DH(1,5) = 4.*T
      DH(1,6) = -4.*T
      DH(2,1) = -3. + 4.*S + 4.*T
      DH(2,2) = 0.0
      DH(2,3) = -1. + 4.*T
      DH(2,4) = -4.*S
      DH(2,5) = 4.*S
      DH(2,6) = 4. -4.*S - 8.*T
      RETURN
      END
      SUBROUTINE  DER8H (R,S,T,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOCAL DERIVATIVES FOR EIGHT NODE HEXAHEDRON
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(3,8)
C     R,S,T = LOCAL COORDINATES OF THE POINT
C     DH(1,K)=DH/DR, DH(2,K)=DH/DS, DH(3,K)=DH/DT
C     H = ELEMENT SHAPE FUNCTIONS, SEE SHP8H
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      TP = 1. + T
      TM = 1. - T
      DH(1,1) =  0.125*SP*TP
      DH(2,1) =  0.125*RP*TP
      DH(3,1) =  0.125*RP*SP
      DH(1,2) =  0.125*SM*TP
      DH(2,2) = -0.125*RP*TP
      DH(3,2) =  0.125*RP*SM
      DH(1,3) =  0.125*SM*TM
      DH(2,3) = -0.125*RP*TM
      DH(3,3) = -0.125*RP*SM
      DH(1,4) =  0.125*SP*TM
      DH(2,4) =  0.125*RP*TM
      DH(3,4) = -0.125*RP*SP
      DH(1,5) = -0.125*SP*TP
      DH(2,5) =  0.125*RM*TP
      DH(3,5) =  0.125*RM*SP
      DH(1,6) = -0.125*SM*TP
      DH(2,6) = -0.125*RM*TP
      DH(3,6) =  0.125*RM*SM
      DH(1,7) = -0.125*SM*TM
      DH(2,7) = -0.125*RM*TM
      DH(3,7) = -0.125*RM*SM
      DH(1,8) = -0.125*SP*TM
      DH(2,8) =  0.125*RM*TM
      DH(3,8) = -0.125*RM*SP
      RETURN
      END
      SUBROUTINE  DER8Q (S,T,DH)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND LOCAL DERIVATIVES OF SHAPE FUNCTIONS FOR AN
C     EIGHT NODE ISOPARAMETRIC QUADRILATERAL ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DH(2,8)
C     S,T = LOCAL COORDINATES OF POINT, SEE SHP8Q
C     DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS, H
C     DH(1,J) = DH(J)/DS,  DH(2,J) = DH(J)/DT
C     H = SHAPE FUNCTION ARRAY
      SP = 1. + S
      SM = 1. - S
      TP = 1. + T
      TM = 1. - T
      DH(1,1) = -0.25*TM*( SM + SM + TM - 3. )
      DH(2,1) = -0.25*SM*( TM + SM + TM - 3. )
      DH(1,2) =  0.25*TM*( SP + SP + TM - 3. )
      DH(2,2) = -0.25*SP*( TM + SP + TM - 3. )
      DH(1,3) =  0.25*TP*( SP + SP + TP - 3. )
      DH(2,3) =  0.25*SP*( TP + SP + TP - 3. )
      DH(1,4) = -0.25*TP*( SM + SM + TP - 3. )
      DH(2,4) =  0.25*SM*( TP + SM + TP - 3. )
      DH(1,5) = -S*TM
      DH(2,5) = -0.5*( 1. - S*S )
      DH(1,6) =  0.5*( 1. - T*T )
      DH(2,6) = -T*SP
      DH(1,7) = -S*TP
      DH(2,7) =  0.5*( 1. - S*S )
      DH(1,8) = -0.5*( 1. - T*T )
      DH(2,8) = -T*SM
      RETURN
      END
      SUBROUTINE DER9Q ( R, S, DH ) 
C     * * * * * * * * * * * * * * * * * * * * * * * 
C     LOCAL DERIVATIVES FOR 9-NODED QUAD
C     * * * * * * * * * * * * * * * * * * * * * * * 
C     SEE SHP9Q FOR TOPOLOGY
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DH(2,9)
      RM = R - 1.D0
      SM = S - 1.D0
      RP = R + 1.D0
      SP = S + 1.D0
      S2P1 = S + S + 1.D0
      S2M1 = S + S - 1.D0
      R2P1 = R + R + 1.D0
      R2M1 = R + R - 1.D0
      DH(1,1) = 0.25D0 * S * SM * R2M1
      DH(1,2) = 0.25D0 * S * SM * R2P1
      DH(1,3) = 0.25D0 * S * SP * R2P1
      DH(1,4) = 0.25D0 * S * SP * R2M1
      DH(1,5) = -S * SM * R
      DH(1,6) = -0.5D0 * SP * SM * R2P1
      DH(1,7) = -S * SP * R
      DH(1,8) = -0.5D0 * SP * SM * R2M1
      DH(1,9) = 2.D0 * SP * SM * R
      DH(2,1) = 0.25D0 * S2M1 * R * RM
      DH(2,2) = 0.25D0 * S2M1 * R * RP
      DH(2,3) = 0.25D0 * S2P1 * R * RP
      DH(2,4) = 0.25D0 * S2P1 * R * RM
      DH(2,5) = -0.5D0 * S2M1 * RP * RM
      DH(2,6) = -S * R * RP
      DH(2,7) = -0.5D0 * S2P1 * RP * RM
      DH(2,8) = -S * R * RM
      DH(2,9) = 2.D0 * S * RP * RM
      RETURN 
      END
      SUBROUTINE  DERCU (B, A, DH)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     FIRST DERIVATIVES OF SHAPE FUNCTIONS FOR 1-D
C     CUBIC HERMITE ELEMENT   (A C1 ELEMENT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DH(4)
C     A  = LENGTH OF ELEMENT (SEE SUBR SHPCU)
C     B  = COORDINATE OF POINT
C     DH = FIRST DERIVATIVES OF H
      DH(1) = 6.*(B*B - B)/A
      DH(2) = 1. - 4.*B + 3.*B*B
      DH(3) = 6.*(B - B*B)/A
      DH(4) = 3.*B*B - 2.*B
      RETURN
      END
      SUBROUTINE  DERHQL (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE,
     &                    RST, DERIV)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        SHAPE FUNCTION DERIVATIVES FOR GENERAL SERENDIPITY 
C               LINE, QUAD, OR OR HEXAHEDRON WITH AN 
C              ARBITRARY NUMBER OF NODES ON EACH EDGE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( MAXDEG = 20 )
      DIMENSION  RST(3),     BLKCRD(3,8), POLI2(3),  CDRFN(3), 
     &           FARSID(3),  DERIV(3),    CRDEDG(3,MAXDEG+1), 
     &           NODEDG(12), NEATC(3,8),  NODEOP(2,12), 
     &           NODATC(3),  LOCAL(12)
      DATA BLKCRD
     &/ -1.,-1.,-1.,   1.,-1.,-1.,   1.,1.,-1.,   -1.,1.,-1.,
     &  -1.,-1., 1.,   1.,-1., 1.,   1.,1., 1.,   -1.,1., 1./
      DATA NEATC /  1,4,9,   1,2,10,  3,2,11,  3,4,12,
     &              5,8,9,   5,6,10,  7,6,11,  7,8,12 /
      DATA NODEOP / 7,8,  8,5,  5,6,   6,7,
     &              3,4,  4,1,  1,2,   2,3,
     &              3,7,  4,8,  1,5,   2,6 /
      DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 /
C     BLKCRD  = BLOCK CORNER LOCAL COORDINATES
C     CRDEDG  = LOCAL COORDINATES OF SIDE NODES JOINING CORNER
C     FARSID  = FAR SIDE LOCAL COORDINATE
C     LEDGES  = NUMBER OF ELEMENT EDGES, 1, 4, OR 12
C     LOCAL   = LOCAL COORDINATE PARALLEL TO EACH EDGE
C     LOCATE  = POSITION NUMBER ON EDGE, 0 IF CORNER
C     MAXDEG  = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE
C     NEATC   = THE 1, 2, OR 3 EDGES AT A CORNER
C     NEDGE   = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED
C     NODATC  = NUMBER OF SIDE NODES JOINING A CORNER
C     NODEDG  = NUMBER ON NODES ON 1,4, OR 12 EDGES
C     NODEOP  = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE
C     NSPACE  = NUMBER OF SPATIAL DIMENSIONS
C     RST     = LOCAL COORDINATES FOR EVALUATION
C     VALUE   = SHAPE FUNCTION VALUE (RETURNED)
C
C     VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT )
C     DERIV = DA(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT )
C           + A(R,S,T)*( DP1(R) + DP2(S) + DP3(T) )
C
C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE
C      FUNCTIONS IN SERENDIPITY ELEMENTS", ENG COMP,8,19-31,1991
C
C   T:  S      C8 *---E7----* C7     T:  S         8---15----7   
C    : /         /.        /:         : /         /.        /:
C    :/         / .       / :         :/         / 22      / :
C    *---R     / E12     /  E11       *---R     /  .      /  20 
C            E8   .     E6  :                 16   21    /   :
C            /    .    /    :                 /    .    /    :
C           /   C4*.../.E3..* C3             /     4.13/.12..3   
C          /     .   /     /                /     .   /     /
C      C5 *--E5-----* C6  /                5---------6     /
C         :    .    :    /                 :    .    :    11
C         :  E4     :   E2                 :  14    19   /   
C        E9  .    E10  /                  17  .      :  10
C         : .       : /                    : .      18 /
C         :.        :/                     :.        :/
C      C1 *---E1----* C2                   1----9----2
C CORNER NODE & EDGE NUMBERS.   22 NODES: CORNERS, THEN BY EDGES. 
C                               CCW IF |T|=1, ELSE IN POSITIVE T.
C                       === 3-D FORM ===
C
C      C4 *---E3----* C3                   4----8----3     
C         :    .    :         :S           :         :   
C         :         :         :            :         :
C        E4        E2         :            9         :  
C         :         :         *---R        :         :
C         :         :                      :         :
C      C1 *---E1----* C2                   1--5-6-7--2 
C CORNER NODE & EDGE NUMBERS.  9 NODES: CORNERS, THEN BY EDGE ORDER.
C                        === 2-D FORM ===
C
C      C1 *---E1----* C2                   1--2-3-4--5 
C CORNER NODE & EDGE NUMBERS.       9 NODES NUMBERED BY EDGE ORDER.
C                        === 1-D FORM ===
      POLI1 = 1.
      IF ( LOCATE .EQ. 0 ) THEN
C
C  SHAPE FUNCTION FOR CORNER NODES
C
        DO 100 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE))
     &            /(2*BLKCRD(ICORD,NEDGE))
  100   CONTINUE
        CPNUL = 1.
        POLI2(1) = 0.
        POLI2(2) = 0.
        POLI2(3) = 0.
        DO 200 ICORD = 1,NSPACE
          NSIDE = NEATC(ICORD,NEDGE)
          NODATC(ICORD) = NODEDG(NSIDE) - 2
          IF ( NODATC(ICORD) .GT. 0 ) THEN
            IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN'
            CPNUL = CPNUL - 1.
            POLI2(ICORD) = 1.
            FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1)
            DO 300 INODE = 1,NODATC(ICORD)
              CRDEDG(ICORD,INODE) =  -1. + FARSID(ICORD)*INODE
              POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) 
     &                     - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE)
     &                     - CRDEDG(ICORD,INODE))
  300       CONTINUE
          ENDIF
  200   CONTINUE
C       VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL)
      ELSE
C
C  SHAPE FUNCTION FOR EDGE NODES
C
        NOPV1 = NODEOP(1,NEDGE)
        NOPV2 = NODEOP(2,NEDGE)
        ISRFN = ABS(LOCAL(NEDGE))
        FARSID(1) = 2./(NODEDG(NEDGE) - 1)
        CDRFN(1) =  -BLKCRD(1,NOPV1)
        CDRFN(2) =  -BLKCRD(2,NOPV1)
        CDRFN(3) =  -BLKCRD(3,NOPV1)
        CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN
        DO 400 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1))
     &           /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1))
  400   CONTINUE
        PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2))
     &         /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2))
        POLI3 = 1.
        NODATC(1) = NODEDG(NEDGE) - 2
        IF ( NODATC(1) .GT. 0 ) THEN
          IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN'
          DO 500 INODE = 1,NODATC(1)
            CRDEDG(1,INODE) =  -1. + FARSID(1)*INODE
            IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001)
     &      THEN
              POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE))
     &               /(CDRFN(ISRFN) - CRDEDG(1,INODE))
            ENDIF
  500     CONTINUE
        ENDIF
C       VALUE = POLI1*PLAN2*POLI3
      ENDIF
C
C  DERIVATIVES OF SHAPE FUNCTIONS
C
      DO 600 ICOR1 = 1,NSPACE
        IF ( LOCATE .EQ. 0 ) THEN
C
C  DERIVATIVES FOR CORNER NODES
C
          DPOL1 = POLI2(1) + POLI2(2) + POLI2(3) + CPNUL
          DO 700 ICOR2 = 1,NSPACE
            IF ( ICOR2 .NE. ICOR1 ) THEN
              DPOL1 = DPOL1*(RST(ICOR2) + BLKCRD(ICOR2,NEDGE))
     &               /(2*BLKCRD(ICOR2,NEDGE))
            ELSE
              DPOL1 = DPOL1/(2*BLKCRD(ICOR2,NEDGE))
            ENDIF
  700     CONTINUE
          DPOL2 = 0.
          DO 800 INOD1 = 1,NODATC(ICOR1)
            DETP2 = 1.
            DO 900 INOD2 = 1,NODATC(ICOR1)
              IF ( INOD2 .NE. INOD1 ) THEN
                DETP2 = DETP2*(RST(ICOR1) - CRDEDG(ICOR1,INOD2))
     &                 /(BLKCRD(ICOR1,NEDGE) - CRDEDG(ICOR1,INOD2))
              ELSE
                DETP2 = DETP2/(BLKCRD(ICOR1,NEDGE)
     &                - CRDEDG(ICOR1,INOD2))
              ENDIF
  900       CONTINUE
            DPOL2 = DPOL2 + DETP2
  800     CONTINUE
          DPOL2 = DPOL2*POLI1
          DERIV(ICOR1) = DPOL1 + DPOL2
        ELSE
C
C  DERIVATIVES FOR EDGE NODES
C
          DPOL1 = POLI3*PLAN2
          DO 1000 ICOR2 = 1,NSPACE
            IF ( ICOR2 .NE. ICOR1 ) THEN
              DPOL1 = DPOL1*(RST(ICOR2) - BLKCRD(ICOR2,NOPV1))
     &               /(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1))
            ELSE
              DPOL1 = DPOL1/(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1))
            ENDIF
 1000     CONTINUE
          DPLA2 = 0.
          DPOL3 = 0.
          IF ( ICOR1 .EQ. ISRFN ) THEN
            DPLA2 = POLI1*POLI3/(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2))
            DO 1100 INOD1 = 1,NODATC(1)
              IF ( ABS(CRDEDG(1,INOD1) - CDRFN(ISRFN)) .GT. 0.0001)
     &        THEN
                DETP3 = 1.
                DO 1200 INOD2 = 1,NODATC(1)
                  IF ( ABS(CRDEDG(1,INOD2) - CDRFN(ISRFN)) .GT.
     &                 0.0001 ) THEN
                    IF ( INOD2 .NE. INOD1 ) THEN
                      DETP3 = DETP3*(RST(ISRFN) - CRDEDG(1,INOD2))
     &                        /(CDRFN(ISRFN) - CRDEDG(1,INOD2))
                    ELSE
                      DETP3 = DETP3/(CDRFN(ISRFN) - CRDEDG(1,INOD2))
                    ENDIF
                  ENDIF
 1200           CONTINUE
                DPOL3 = DPOL3 + DETP3
              ENDIF
 1100       CONTINUE
            DPOL3 = DPOL3*POLI1*PLAN2
          ENDIF
          DERIV(ICOR1) = DPOL1 + DPLA2 + DPOL3
	ENDIF
  600   CONTINUE
      RETURN
      END
      SUBROUTINE  DERIV (PT, DLH, N, NSPACE, LSHAPE, NG, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C         EVALUATE C0 INTERPOLATION LOCAL DERIVATIVES
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DLH(NSPACE,N), PT(NSPACE), LNODE(N)
C     DLH    = LOCAL DERIVATIVES AT PT
C     LNODE  = TOPOLOGY LIST, IF VARIABLE
C     LSHAPE = 1-LINE, 2-TRI, 3-QUAD, 4-HEX, 5-TET, 6-WEDGE
C     N      = NUMBER OF NODES PER ELEMENT
C     NG     = NUMBER OF DEGREES OF FREEDOM PER NODE
C     NSPACE = NO OF SPATIAL DIMENSIONS
C     PT     = LOCAL COORD OF A POINT
C
C      BRANCH ON SHAPE, THEN NUMBER OF NODES
      IF ( LSHAPE .LE. 1 )  THEN
C-->     1-D ELEMENTS
        IF ( N .EQ. 2 ) CALL DER2L (PT(1),DLH)
c       IF ( N .EQ. 3 ) CALL DER3L (PT(1),DLH)
        RETURN
      ELSEIF ( LSHAPE .EQ. 2 ) THEN
C-->     TRIANGULAR 2-D ELEMENTS
        IF ( N .EQ. 3 )  CALL DER3T (PT(1),PT(2),DLH)
C       IF ( N .EQ. 4 )  CALL DER4T (PT(1),PT(2),DLH)
        IF ( N .EQ. 6 )  CALL DER6T (PT(1),PT(2),DLH)
C       IF ( N .EQ. 7 )  CALL DER7T (PT(1),PT(2),DLH)
C       IF ( N .EQ. 10 ) CALL DER10T (PT(1),PT(2),DLH)
C       IF ( N .EQ. 15 ) CALL DER15T (PT(1),PT(2),DLH)
        RETURN
      ELSEIF ( LSHAPE .EQ. 3 )  THEN
C-->     QUADRILATERAL 2-D ELEMENTS
        IF ( N .EQ. 4 )  CALL DER4Q (PT(1),PT(2),DLH)
        IF ( N .EQ. 8 )  CALL DER8Q (PT(1),PT(2),DLH)
        IF ( N .EQ. 9 )  CALL DER9Q (PT(1),PT(2),DLH)
C       IF ( N .EQ. 12 ) CALL DER412 (PT(1),PT(2),DLH,LNODE)
C       IF ( N .EQ. 16 ) CALL DER16Q (PT(1),PT(2),DLH)
C       IF ( N .EQ. 17 ) CALL DER17Q (PT(1),PT(2),DLH)
C       IF ( N .EQ. 25 ) CALL DER25Q (PT(1),PT(2),DLH)
        RETURN
      ELSEIF ( LSHAPE .EQ. 4 )  THEN
C-->     HEXAHEDRA 3-D ELEMENTS
        IF ( N .EQ. 8 )  CALL DER8H  (PT(1),PT(2),PT(3),DLH)
c       IF ( N .EQ. 20 ) CALL DER208 (PT(1),PT(2),PT(3),DLH,LNODE)
C       IF ( N .EQ. 27 ) CALL DER27H (PT(1),PT(2),PT(3),DLH)
C       IF ( N .EQ. 32 ) CALL DER32H (PT(1),PT(2),PT(3),DLH)
        RETURN
      ELSEIF ( LSHAPE .EQ. 5 )  THEN
C-->     TETRAHEDRA 3-D ELEMENTS (PYRAMIDS)
c       IF ( N .EQ. 4 )  CALL DER4P  (PT(1),PT(2),PT(3),DLH)
C       IF ( N .EQ. 10 ) CALL DER10P (PT(1),PT(2),PT(3),DLH)
C       IF ( N .EQ. 21 ) CALL DER21P (PT(1),PT(2),PT(3),DLH)
        RETURN
      ELSEIF ( LSHAPE .EQ. 6 )  THEN
C-->     WEDGE 3-D ELEMENTS 
        STOP 'NO WEDGE IN SHAPE'
C       IF ( N .EQ. 6 )  CALL DER6W  (PT(1),PT(2),PT(3),DLH)
C       IF ( N .EQ. 15 ) CALL DER15W (PT(1),PT(2),PT(3),DLH)
C       RETURN
      ELSEIF ( LSHAPE .EQ. 7 )  THEN
C-->     USER SUPPLIED ELEMENT
C       CALL  DERUSR (PT(1),PT(2),PT(3),DLH,LNODE)
        STOP 'NO USER ELEMENT IN DERIV'
      ELSEIF ( LSHAPE .GT. 7 )  THEN
C-->     UNSUPPORTED OPTION
        STOP 'UNSUPPORTED ELEMENT IN DERIV'
      ENDIF
      RETURN
      END
      SUBROUTINE DERSHPH (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE,
     &                    RST, VALUE, DERIV)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        SHAPE FUNCTIONS AND DERIVATIVES FOR GENERAL SERENDIPITY 
C               LINE, QUAD, OR OR HEXAHEDRON WITH AN 
C              ARBITRARY NUMBER OF NODES ON EACH EDGE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( MAXDEG = 20 )
      DIMENSION  RST(3),     BLKCRD(3,8), POLI2(3),  CDRFN(3), 
     &           FARSID(3),  DERIV(3),    CRDEDG(3,MAXDEG+1), 
     &           NODEDG(12), NEATC(3,8),  NODEOP(2,12), 
     &           NODATC(3),  LOCAL(12)
      DATA BLKCRD
     &/ -1.,-1.,-1.,   1.,-1.,-1.,   1.,1.,-1.,   -1.,1.,-1.,
     &  -1.,-1., 1.,   1.,-1., 1.,   1.,1., 1.,   -1.,1., 1./
      DATA NEATC /  1,4,9,   1,2,10,  3,2,11,  3,4,12,
     &              5,8,9,   5,6,10,  7,6,11,  7,8,12 /
      DATA NODEOP / 7,8,  8,5,  5,6,   6,7,
     &              3,4,  4,1,  1,2,   2,3,
     &              3,7,  4,8,  1,5,   2,6 /
      DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 /
C     BLKCRD  = BLOCK CORNER LOCAL COORDINATES
C     CRDEDG  = LOCAL COORDINATES OF SIDE NODES JOINING CORNER
C     DERIV   = SHAPE FUNCTION DERIVATIVES (RETURNED)
C     FARSID  = FAR SIDE LOCAL COORDINATE
C     LEDGES  = NUMBER OF ELEMENT EDGES, 1, 4, OR 12
C     LOCAL   = LOCAL COORDINATE PARALLEL TO EACH EDGE
C     LOCATE  = POSITION NUMBER ON EDGE, 0 IF CORNER
C     MAXDEG  = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE
C     NEATC   = THE 1, 2, OR 3 EDGES AT A CORNER
C     NEDGE   = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED
C     NODATC  = NUMBER OF SIDE NODES JOINING A CORNER
C     NODEDG  = NUMBER ON NODES ON 1,4, OR 12 EDGES
C     NODEOP  = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE
C     NSPACE  = NUMBER OF SPATIAL DIMENSIONS
C     RST     = LOCAL COORDINATES FOR EVALUATION
C     VALUE   = SHAPE FUNCTION VALUE (RETURNED)
C
C     VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT )
C     DERIV = DA(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT )
C           + A(R,S,T)*( DP1(R) + DP2(S) + DP3(T) )
C
C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE
C      FUNCTIONS IN SERENDIPITY ELEMENTS, I.J.N.M.E."
C
C   T:  S      C8 *---E7----* C7     T:  S         8---15----7   
C    : /         /.        /:         : /         /.        /:
C    :/         / .       / :         :/         / 22      / :
C    *---R     / E12     /  E11       *---R     /  .      /  20 
C            E8   .     E6  :                 16   21    /   :
C            /    .    /    :                 /    .    /    :
C           /   C4*.../.E3..* C3             /     4.13/.12..3   
C          /     .   /     /                /     .   /     /
C      C5 *--E5-----* C6  /                5---------6     /
C         :    .    :    /                 :    .    :    11
C         :  E4     :   E2                 :  14    19   /   
C        E9  .    E10  /                  17  .      :  10
C         : .       : /                    : .      18 /
C         :.        :/                     :.        :/
C      C1 *---E1----* C2                   1----9----2
C CORNER NODE & EDGE NUMBERS.   22 NODES: CORNERS, THEN BY EDGES. 
C                               CCW IF |T|=1, ELSE IN POSITIVE T.
C                       === 3-D FORM ===
C
C      C4 *---E3----* C3                   4----8----3     
C         :    .    :         :S           :         :   
C         :         :         :            :         :
C        E4        E2         :            9         :  
C         :         :         *---R        :         :
C         :         :                      :         :
C      C1 *---E1----* C2                   1--5-6-7--2 
C CORNER NODE & EDGE NUMBERS.  9 NODES: CORNERS, THEN BY EDGE ORDER.
C                        === 2-D FORM ===
C
C      C1 *---E1----* C2                   1--2-3-4--5 
C CORNER NODE & EDGE NUMBERS.       9 NODES NUMBERED BY EDGE ORDER.
C                        === 1-D FORM ===
      POLI1 = 1.
      IF ( LOCATE .EQ. 0 ) THEN
C
C  SHAPE FUNCTION FOR CORNER NODES
C
        DO 100 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE))
     &            /(2*BLKCRD(ICORD,NEDGE))
  100   CONTINUE
        CPNUL = 1.
        POLI2(1) = 0.
        POLI2(2) = 0.
        POLI2(3) = 0.
        DO 200 ICORD = 1,NSPACE
          NSIDE = NEATC(ICORD,NEDGE)
          NODATC(ICORD) = NODEDG(NSIDE) - 2
          IF ( NODATC(ICORD) .GT. 0 ) THEN
            IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN'
            CPNUL = CPNUL - 1.
            POLI2(ICORD) = 1.
            FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1)
            DO 300 INODE = 1,NODATC(ICORD)
              CRDEDG(ICORD,INODE) =  -1. + FARSID(ICORD)*INODE
              POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) 
     &                     - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE)
     &                     - CRDEDG(ICORD,INODE))
  300       CONTINUE
          ENDIF
  200   CONTINUE
        VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL)
      ELSE
C
C  SHAPE FUNCTION FOR EDGE NODES
C
        NOPV1 = NODEOP(1,NEDGE)
        NOPV2 = NODEOP(2,NEDGE)
        ISRFN = ABS(LOCAL(NEDGE))
        FARSID(1) = 2./(NODEDG(NEDGE) - 1)
        CDRFN(1) =  -BLKCRD(1,NOPV1)
        CDRFN(2) =  -BLKCRD(2,NOPV1)
        CDRFN(3) =  -BLKCRD(3,NOPV1)
        CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN
        DO 400 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1))
     &           /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1))
  400   CONTINUE
        PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2))
     &         /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2))
        POLI3 = 1.
        NODATC(1) = NODEDG(NEDGE) - 2
        IF ( NODATC(1) .GT. 0 ) THEN
          IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN'
          DO 500 INODE = 1,NODATC(1)
            CRDEDG(1,INODE) =  -1. + FARSID(1)*INODE
            IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001)
     &      THEN
              POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE))
     &               /(CDRFN(ISRFN) - CRDEDG(1,INODE))
            ENDIF
  500     CONTINUE
        ENDIF
        VALUE = POLI1*PLAN2*POLI3
      ENDIF
C
C  DERIVATIVES OF SHAPE FUNCTIONS
C
      DO 600 ICOR1 = 1,NSPACE
        IF ( LOCATE .EQ. 0 ) THEN
C
C  DERIVATIVES FOR CORNER NODES
C
          DPOL1 = POLI2(1) + POLI2(2) + POLI2(3) + CPNUL
          DO 700 ICOR2 = 1,NSPACE
            IF ( ICOR2 .NE. ICOR1 ) THEN
              DPOL1 = DPOL1*(RST(ICOR2) + BLKCRD(ICOR2,NEDGE))
     &               /(2*BLKCRD(ICOR2,NEDGE))
            ELSE
              DPOL1 = DPOL1/(2*BLKCRD(ICOR2,NEDGE))
            ENDIF
  700     CONTINUE
          DPOL2 = 0.
          DO 800 INOD1 = 1,NODATC(ICOR1)
            DETP2 = 1.
            DO 900 INOD2 = 1,NODATC(ICOR1)
              IF ( INOD2 .NE. INOD1 ) THEN
                DETP2 = DETP2*(RST(ICOR1) - CRDEDG(ICOR1,INOD2))
     &                 /(BLKCRD(ICOR1,NEDGE) - CRDEDG(ICOR1,INOD2))
              ELSE
                DETP2 = DETP2/(BLKCRD(ICOR1,NEDGE)
     &                - CRDEDG(ICOR1,INOD2))
              ENDIF
  900       CONTINUE
            DPOL2 = DPOL2 + DETP2
  800     CONTINUE
          DPOL2 = DPOL2*POLI1
          DERIV(ICOR1) = DPOL1 + DPOL2
        ELSE
C
C  DERIVATIVES FOR EDGE NODES
C
          DPOL1 = POLI3*PLAN2
          DO 1000 ICOR2 = 1,NSPACE
            IF ( ICOR2 .NE. ICOR1 ) THEN
              DPOL1 = DPOL1*(RST(ICOR2) - BLKCRD(ICOR2,NOPV1))
     &               /(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1))
            ELSE
              DPOL1 = DPOL1/(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1))
            ENDIF
 1000     CONTINUE
          DPLA2 = 0.
          DPOL3 = 0.
          IF ( ICOR1 .EQ. ISRFN ) THEN
            DPLA2 = POLI1*POLI3/(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2))
            DO 1100 INOD1 = 1,NODATC(1)
              IF ( ABS(CRDEDG(1,INOD1) - CDRFN(ISRFN)) .GT. 0.0001)
     &        THEN
                DETP3 = 1.
                DO 1200 INOD2 = 1,NODATC(1)
                  IF ( ABS(CRDEDG(1,INOD2) - CDRFN(ISRFN)) .GT.
     &                 0.0001 ) THEN
                    IF ( INOD2 .NE. INOD1 ) THEN
                      DETP3 = DETP3*(RST(ISRFN) - CRDEDG(1,INOD2))
     &                        /(CDRFN(ISRFN) - CRDEDG(1,INOD2))
                    ELSE
                      DETP3 = DETP3/(CDRFN(ISRFN) - CRDEDG(1,INOD2))
                    ENDIF
                  ENDIF
 1200           CONTINUE
                DPOL3 = DPOL3 + DETP3
              ENDIF
 1100       CONTINUE
            DPOL3 = DPOL3*POLI1*PLAN2
          ENDIF
          DERIV(ICOR1) = DPOL1 + DPLA2 + DPOL3
	ENDIF
  600   CONTINUE
      RETURN
      END
      FUNCTION  DOT (N, A, B)
C     * * * * * * * * * * * * * * * * *
C     DOT PRODUCT OF VECTORS A(N)*B(N)
C     * * * * * * * * * * * * * * * * * 
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(N), B(N)
      DOT = 0.0
      DO 10  I = 1,N
 10   DOT = DOT + A(I)*B(I)
      RETURN
      END
      SUBROUTINE  DQRULE  (IDEG, NQP, NCORD, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C         DUNAVANT QUADRATURE RULE FOR TRIANGLES, TO DEGREE = 17
C      IN AREA COORDINATES (NCORD=3), OR UNIT COORDINATES (NCORD=2)
C              I.J.N.M.E. VOL. 21, PP.1129-1148, 1985
C     INPUT IDEG=0,1,2,3,4,5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,NQP=0
C      OR    NQP=1,1,3,4,6,7,12,13,16,19,25,27,33,37,42,48,52,61
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C WARNING:  REQUIRES COMPILER FLAG FOR 40 CONTINUATION LINES,-Nl40 <=====
      IMPLICIT REAL*8 (A-H,O,R-V,X-Z)
      DIMENSION  PT(NCORD,0:*), WT(0:*)
      DIMENSION  AW(107), A1(107), A2(107), A3(107),
     1           NQPDEG(17), ISTART(17), LINES(17), KOUNTS(107)
C     IDEG     = DEGREE OF POLYNOMIAL TO BE INTEGRATED, 0 TO 17
C     NQP      = NUMBER OF QUADRATURE POINTS, USE 0 IF IDEG GOVERNS   
C     NCORD    = NUMBER OF PARAMETRIC DIMENSIONS: 3-AREA, 2-UNIT CORD
C     PT       = RETURNED QUADRATURE COORDINATES, PT(NCORD,NQP)
C     WT       = RETURNED QUADRATURE WEIGHTS,     WT(NQP)
C
C     NQPDEG   = NUMBER QUADRATURE PTS FOR POLYNOMIAL DEGREE
C     ISTART   = WHERE IDEG RULE DATA STARTS IN DATA TABLES
C     LINES    = NUMBER OF LINES OF DATA FOR EACH RULE
C     KOUNTS   = NUMBER OF TIMES THAT A RULE LINE IS USED
C     A1,A2,A3 = AREA COORDINATES OF TABLE POINT
C     AW       = AREA WEIGHT OF TABLE POINT
      DATA NQPDEG /1,3,4,6,7,12,13,16,19,25,27,33,37,42,48,52,61/
      DATA LINES  /1,1,2,2,3, 3, 4, 5, 6, 6, 7, 8,10,10,11,13,15/
      DATA ISTART /1,2,3,5,7,10,13,17,22,28,34,41,49,59,69,80,93/
      DATA KOUNTS /1,3,1,3,3,3,1,3,3,3,3,6,1,3,3,6,1,3,3,3,6,1,3,3,3,
     1             3,6,1,3,3,6,6,6,3,3,3,3,3,6,6,3,3,3,3,3,6,6,6,1,3,
     2             3,3,3,3,3,6,6,6,3,3,3,3,3,3,6,6,6,6,3,3,3,3,3,3,6,
     3             6,6,6,6,1,3,3,3,3,3,3,3,6,6,6,6,6,1,3,3,3,3,3,3,3,
     4             3,6,6,6,6,6,6 /
      DATA  AW /
     +  1.000000000000000,  0.333333333333333, -0.562500000000000,
     +  0.520833333333333,  0.223381589678011,  0.109951743655322,
     +  0.225000000000000,  0.132394152788506,  0.125939180544827,
     +  0.116786275726379,  0.050844906370207,  0.082851075618374,
     + -0.149570044467682,  0.175615257433208,  0.053347235608838,
     +  0.077113760890257,  0.144315607677787,  0.095091634267285,
     +  0.103217370534718,  0.032458497623198,  0.027230314174435,
     +  0.097135796282799,  0.031334700227139,  0.077827541004774,
     +  0.079647738927210,  0.025577675658698,  0.043283539377289,
     +  0.090817990382754,  0.036725957756467,  0.045321059435528,
     +  0.072757916845420,  0.028327242531057,  0.009421666963733,
     +  0.000927006328961,  0.077149534914813,  0.059322977380774,
     +  0.036184540503418,  0.013659731002678,  0.052337111962204,
     +  0.020707659639141,  0.025731066440455,  0.043692544538038,
     +  0.062858224217885,  0.034796112930709,  0.006166261051559,
     +  0.040371557766381,  0.022356773202303,  0.017316231108659,
     +  0.052520923400802,  0.011280145209330,  0.031423518362454,
     +  0.047072502504194,  0.047363586536355,  0.031167529045794,
     +  0.007975771465074,  0.036848402728732,  0.017401463303822,
     +  0.015521786839045,  0.021883581369429,  0.032788353544125,
     +  0.051774104507292,  0.042162588736993,  0.014433699669777,
     +  0.004923403602400,  0.024665753212564,  0.038571510787061,
     +  0.014436308113534,  0.005010228838501,  0.001916875642849,
     +  0.044249027271145,  0.051186548718852,  0.023687735870688,
     +  0.013289775690021,  0.004748916608192,  0.038550072599593,
     +  0.027215814320624,  0.002182077366797,  0.021505319847731,
     +  0.007673942631049,  0.046875697427642,  0.006405878578585,
     +  0.041710296739387,  0.026891484250064,  0.042132522761650,
     +  0.030000266842773,  0.014200098925024,  0.003582462351273,
     +  0.032773147460627,  0.015298306248441,  0.002386244192839,
     +  0.019084792755899,  0.006850054546542,  0.033437199290803,
     +  0.005093415440507,  0.014670864527638,  0.024350878353672,
     +  0.031107550868969,  0.031257111218620,  0.024815654339665,
     +  0.014056073070557,  0.003194676173779,  0.008119655318993,
     +  0.026805742283163,  0.018459993210822,  0.008476868534328,
     +  0.018292796770025,  0.006665632004165 /
      DATA  A1 /
     +  0.333333333333333,  0.666666666666667,  0.333333333333333,
     +  0.600000000000000,  0.108103018168070,  0.816847572980459,
     +  0.333333333333333,  0.059715871789770,  0.797426985353087,
     +  0.501426509658179,  0.873821971016996,  0.053145049844817,
     +  0.333333333333333,  0.479308067841920,  0.869739794195568,
     +  0.048690315425316,  0.333333333333333,  0.081414823414554,
     +  0.658861384496480,  0.898905543365938,  0.008394777409958,
     +  0.333333333333333,  0.020634961602525,  0.125820817014127,
     +  0.623592928761935,  0.910540973211095,  0.036838412054736,
     +  0.333333333333333,  0.028844733232685,  0.781036849029926,
     +  0.141707219414880,  0.025003534762686,  0.009540815400299,
     + -0.069222096541517,  0.202061394068290,  0.593380199137435,
     +  0.761298175434837,  0.935270103777448,  0.050178138310495,
     +  0.021022016536166,  0.023565220452390,  0.120551215411079,
     +  0.457579229975768,  0.744847708916828,  0.957365299093579,
     +  0.115343494534698,  0.022838332222257,  0.025734050548330,
     +  0.333333333333333,  0.009903630120591,  0.062566729780852,
     +  0.170957326397447,  0.541200855914337,  0.771151009607340,
     +  0.950377217273082,  0.094853828379579,  0.018100773278807,
     +  0.022233076674090,  0.022072179275643,  0.164710561319092,
     +  0.453044943382323,  0.645588935174913,  0.876400233818255,
     +  0.961218077502598,  0.057124757403648,  0.092916249356972,
     +  0.014646950055654,  0.001268330932872, -0.013945833716486,
     +  0.137187291433955,  0.444612710305711,  0.747070217917492,
     +  0.858383228050628,  0.962069659517853,  0.133734161966621,
     +  0.036366677396917, -0.010174883126571,  0.036843869875878,
     +  0.012459809331199,  0.333333333333333,  0.005238916103123,
     +  0.173061122901295,  0.059082801866017,  0.518892500060958,
     +  0.704068411554854,  0.849069624685052,  0.966807194753950,
     +  0.103575692245252,  0.020083411655416, -0.004341002614139,
     +  0.041941786468010,  0.014317320230681,  0.333333333333333,
     +  0.005658918886452,  0.035647354750751,  0.099520061958437,
     +  0.199467521245206,  0.495717464058095,  0.675905990683077,
     +  0.848248235478508,  0.968690546064356,  0.010186928826919,
     +  0.135440871671036,  0.054423924290583,  0.012868560833637,
     +  0.067165782413524,  0.014663182224828 /
      DATA  A2 /
     +  0.333333333333333,  0.166666666666667,  0.333333333333333,
     +  0.200000000000000,  0.445948490915965,  0.091576213509771,
     +  0.333333333333333,  0.470142064105115,  0.101286507323456,
     +  0.249286745170910,  0.063089014491502,  0.310352451033784,
     +  0.333333333333333,  0.260345966079040,  0.065130102902216,
     +  0.312865496004874,  0.333333333333333,  0.459292588292723,
     +  0.170569307751760,  0.050547228317031,  0.263112829634638,
     +  0.333333333333333,  0.489682519198738,  0.437089591492937,
     +  0.188203535619033,  0.044729513394453,  0.221962989160766,
     +  0.333333333333333,  0.485577633383657,  0.109481575485037,
     +  0.307939838764121,  0.246672560639903,  0.066803251012200,
     +  0.534611048270758,  0.398969302965855,  0.203309900431282,
     +  0.119350912282581,  0.032364948111276,  0.356620648261293,
     +  0.171488980304042,  0.488217389773805,  0.439724392294460,
     +  0.271210385012116,  0.127576145541586,  0.021317350453210,
     +  0.275713269685514,  0.281325580989940,  0.116251915907597,
     +  0.333333333333333,  0.495048184939705,  0.468716635109574,
     +  0.414521336801277,  0.229399572042831,  0.114424495196330,
     +  0.024811391363459,  0.268794997058761,  0.291730066734288,
     +  0.126357385491669,  0.488963910362179,  0.417644719340454,
     +  0.273477528308839,  0.177205532412543,  0.061799883090873,
     +  0.019390961248701,  0.172266687821356,  0.336861459796345,
     +  0.298372882136258,  0.118974497696957,  0.506972916858243,
     +  0.431406354283023,  0.277693644847144,  0.126464891041254,
     +  0.070808385974686,  0.018965170241073,  0.261311371140087,
     +  0.388046767090269,  0.285712220049916,  0.215599664072284,
     +  0.103575616576386,  0.333333333333333,  0.497380541948438,
     +  0.413469438549352,  0.470458599066991,  0.240553749969521,
     +  0.147965794222573,  0.075465187657474,  0.016596402623025,
     +  0.296555596579887,  0.337723063403079,  0.204748281642812,
     +  0.189358492130623,  0.085283615682657,  0.333333333333333,
     +  0.497170540556774,  0.482176322624625,  0.450239969020782,
     +  0.400266239377397,  0.252141267970953,  0.162047004658461,
     +  0.075875882260746,  0.015654726967822,  0.334319867363658,
     +  0.292221537796944,  0.319574885423190,  0.190704224192292,
     +  0.180483211648746,  0.080711313679564 /
      DATA  A3 /
     +  0.333333333333333,  0.166666666666667,  0.333333333333333,
     +  0.200000000000000,  0.445948490915965,  0.091576213509771,
     +  0.333333333333333,  0.470142064105115,  0.101286507323456,
     +  0.249286745170910,  0.063089014491502,  0.636502499121399,
     +  0.333333333333333,  0.260345966079040,  0.065130102902216,
     +  0.638444188569810,  0.333333333333333,  0.459292588292723,
     +  0.170569307751760,  0.050547228317031,  0.728492392955404,
     +  0.333333333333333,  0.489682519198738,  0.437089591492937,
     +  0.188203535619033,  0.044729513394453,  0.741198598784498,
     +  0.333333333333333,  0.485577633383657,  0.109481575485037,
     +  0.550352941820999,  0.728323904597411,  0.923655933587500,
     +  0.534611048270758,  0.398969302965855,  0.203309900431282,
     +  0.119350912282581,  0.032364948111276,  0.593201213428213,
     +  0.807489003159792,  0.488217389773805,  0.439724392294460,
     +  0.271210385012116,  0.127576145541586,  0.021317350453210,
     +  0.608943235779788,  0.695836086787803,  0.858014033544073,
     +  0.333333333333333,  0.495048184939705,  0.468716635109574,
     +  0.414521336801277,  0.229399572042831,  0.114424495196330,
     +  0.024811391363459,  0.636351174561660,  0.690169159986905,
     +  0.851409537834241,  0.488963910362179,  0.417644719340454,
     +  0.273477528308839,  0.177205532412543,  0.061799883090873,
     +  0.019390961248701,  0.770608554774996,  0.570222290846683,
     +  0.686980167808088,  0.879757171370171,  0.506972916858243,
     +  0.431406354283023,  0.277693644847144,  0.126464891041254,
     +  0.070808385974686,  0.018965170241073,  0.604954466893291,
     +  0.575586555512814,  0.724462663076655,  0.747556466051838,
     +  0.883964574092416,  0.333333333333333,  0.497380541948438,
     +  0.413469438549352,  0.470458599066991,  0.240553749969521,
     +  0.147965794222573,  0.075465187657474,  0.016596402623025,
     +  0.599868711174861,  0.642193524941505,  0.799592720971327,
     +  0.768699721401368,  0.900399064086661,  0.333333333333333,
     +  0.497170540556774,  0.482176322624625,  0.450239969020782,
     +  0.400266239377397,  0.252141267970953,  0.162047004658461,
     +  0.075875882260746,  0.015654726967822,  0.655493203809423,
     +  0.572337590532020,  0.626001190286228,  0.796427214974071,
     +  0.752351005937729,  0.904625504095608 /
C      CHECK FOR IDEG OR NQP CONTROL: 
      LDEG = IDEG
      IF ( NQP .EQ. 0 )  THEN
C        USE DEGREE CONTROL
        IF ( IDEG .EQ. 0 )  NQP = 1
        IF ( IDEG .LT. 0 .OR. IDEG .GT. 17 )  THEN
          STOP 'INVALID IDEG ARGUMENT, DQRULE'
        ELSE
          NQP = NQPDEG(IDEG)
        ENDIF
      ELSE
C        USE NQP CONTROL
        LDEG = 0
        DO  10  I = 1, 17
          IF ( NQP .EQ. NQPDEG(I) )  LDEG = I
 10     CONTINUE
        IF ( LDEG .EQ. 0 )  STOP 'INVALID NQP ARGUMENT, DQRULE'
      ENDIF
C      FOUND VALID RULE, NOW EXPAND TABLE TO FULL RULE
      IPT   = ISTART(LDEG) - 1
      IRULE = 0
      SUM   = 0.D0
      DO 20  I = 1, LINES(LDEG)
        J     = IPT + I
        KOUNT = KOUNTS(J)
        IRULE = IRULE + 1
        SUM   = SUM + AW(J)*KOUNT
        WT(IRULE)   = AW(J)
        PT(1,IRULE) = A1(J)
        PT(2,IRULE) = A2(J)
        IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A3(J)
        IF ( KOUNT .GE. 3 ) THEN
          IRULE = IRULE + 1
          WT(IRULE)   = AW(J)
          PT(1,IRULE) = A3(J)
          PT(2,IRULE) = A1(J)
          IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A2(J)
          IRULE = IRULE + 1
          WT(IRULE)   = AW(J)
          PT(1,IRULE) = A2(J)
          PT(2,IRULE) = A3(J)
          IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A1(J)
        ENDIF
        IF ( KOUNT .EQ. 6 ) THEN
          IRULE = IRULE + 1
          WT(IRULE)   = AW(J)
          PT(1,IRULE) = A1(J)
          PT(2,IRULE) = A3(J)
          IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A2(J)
          IRULE = IRULE + 1
          WT(IRULE)   = AW(J)
          PT(1,IRULE) = A3(J)
          PT(2,IRULE) = A2(J)
          IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A1(J)
          IRULE = IRULE + 1
          WT(IRULE)   = AW(J)
          PT(1,IRULE) = A2(J)
          PT(2,IRULE) = A1(J)
          IF ( NCORD .EQ. 3 )  PT(3,IRULE) = A3(J)
        ENDIF
 20   CONTINUE
C      CHECK VALIDITY OF RESULTS
C     IF ( SUM .NE. 1.D0 )  WRITE (6,*) 
C    1    'WARNING, UNITY NOT', SUM,', DQRULE'
      IF ( NCORD .EQ. 2 )  THEN
        DO 30  I = 1, NQP
 30     WT(I) = WT(I)*0.5D0
      ENDIF
      RETURN
      END
      PROGRAM DRIVER
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     DUMMY MAIN TO SET PROGRAM CAPACITY LIMITS:
C
C     TO INCREASE MEMORY STORAGE SIZE CHANGE PARAMETER
C      MAXR FOR REAL ARRAYS AND/OR
C      MAXI FOR INTEGER ARRAYS
C
C     TO INCREASE THE NUMBER OF ARRAY NAMES & SIZES CHANGE
C      NUMR FOR REAL ARRAYS AND/OR
C      NUMI FOR INTEGER ARRAYS
C
C     ERROR MESSAGES WILL STATE WHEN THESE ARE NECESSARY
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 RN, IN
      PARAMETER (NUMR=      55, MAXR=      9000)
      PARAMETER (NUMI=      25, MAXI=      5000)
      DIMENSION  R(MAXR), RN(NUMR), I(MAXI), IN(NUMI)
      DIMENSION  J(NUMR), K(NUMI)
C
C     USER ACCESS VIA COMMON IS ALLOWED. STANDARD ACCESS IS
C          ALWAYS VIA DUMMY DIMENSION ARGUMENTS
C
      COMMON / REAL /    R, RN, MMAXR, NNUMR, LLASTR, J
      COMMON / INTEGER / MMAXI, NNUMI, LLASTI, I, IN, K
C
C     I      = VECTOR HOLDING ALL INTEGER ARRAYS (APPENDABLE)
C     IN     = NAMES OF EACH INTEGER ARRAY (APPENDABLE)
C     J      = POINTER TO BEGINNING OF EACH REAL ARRAY (APPENDABLE)
C     K      = POINTER TO BEGINNING OF EACH INTEGER ARRAY (APPENDABLE)
C     LASTI  = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY
C     LASTR  = NUMBER OF THE LAST ASSIGNED REAL ARRAY
C     LLASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY (COMMON)
C     LLASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY (COMMON)
C     MAXI   = STORAGE ALLOWED FOR ALL INTEGER ARRAYS
C     MAXR   = STORAGE ALLOWED FOR ALL REAL ARRAYS
C     MMAXI  = STORAGE ALLOWED FOR ALL INTEGER ARRAYS (COMMON)
C     MMAXR  = STORAGE ALLOWED FOR ALL REAL ARRAYS (COMMON)
C     NNUMI  = ALLOWED NUMBER OF INTEGER ARRAYS (VIA COMMON)
C     NNUMR  = ALLOWED NUMBER OF REAL ARRAYS (VIA COMMON)
C     NUMI   = ALLOWED NUMBER OF INTEGER ARRAYS
C     NUMR   = ALLOWED NUMBER OF REAL ARRAYS
C     R      = VECTOR HOLDING ALL REAL ARRAYS (APPENDABLE)
C     RN     = NAMES OF EACH REAL ARRAY (APPENDABLE)
C
C      ALLOW ACCESS VIA COMMON FOR USER APPLICATIONS (NOT USED)
      MMAXR  = MAXR
      MMAXI  = MAXI
      NNUMR  = NUMR
      NNUMI  = NUMI
      LLASTI = 0
      LLASTR = 0
C
C      BUILD DYNAMIC DIMENSION STORAGES AND EXECUTE MODEL
      CALL  DYNDIM (NUMR, MAXR, NUMI, MAXI, R, RN, I, IN,
     1              J, K )
C      NOTE: DYNDIM IS ESSENTIALLY WRITTEN BY PROGRAM DIMMAK.F
C            USING ARRAYS "REALS" AND "INTEGERS", THEN EDITED
C            TO REMOVE BLANKS, ETC.  IT ALSO WRITES MODEL CALL
C            AND DIMENSION STATEMENTS
      STOP 'NORMAL END'
      END
      SUBROUTINE  DSTART (IPRINT, M, NG, NSPACE, NDFREE, 
     1                    INDEX, X, COORD, DD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        INITIALIZE SYSTEM DOF FOR ITERATIVE SOLUTION
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  DD(NDFREE), X(M,NSPACE),
     1           COORD(1,NSPACE), INDEX(NG)
C     M      = NUMBER OF NODES IN SYSTEM
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     NSPACE = DIMENSION OF SPACE
C     NDFREE = TOTAL NUMBER OF SYSTEM DOF
C     INDEX  = SYSTEM DOF NUMBERS FOR DOF AT NODE
C     X      = COORDINATES OF SYSTEM NODES
C     COORD  = SPATIAL COORDINATE ARRAY OF A NODE
C     DD     = SYSTEM ARRAY OF DEGREES OF FREEDOM
C     IPRINT > 0, PRINT THE STARTING VALUES
      IF ( IPRINT .GT. 0 )  WRITE (NPRT,5000)
 5000 FORMAT ( /, 
     1 '** STARTING VALUES FOR ITERATIVE SOLUTION **',/,
     2 'NODE    PARAMETER      VALUE')
      DO 20  I = 1, M
C        FIND PT COORDS AND DOF NOS
        CALL  INDXPT (I,NG,INDEX)
        CALL  PTCORD (I,M,NSPACE,X,COORD)
        DO 10  J = 1, NG
          INDX = INDEX(J)
          DD(INDX) = START(J,NSPACE,COORD)
C         START IS A FUNCTION TO DEFINE INITIAL VALUES
C         OF THE SYSTEM DEGREES OF FREEDOM
          IF ( IPRINT .GT. 0 )  WRITE (NPRT,5010) I,J,DD(INDX)
 5010     FORMAT ( I5, I10, 2X, 1PE13.5 )
 10     CONTINUE
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  DYNDIM (NUMR, MAXR, NUMI, MAXI, R, RN, I, IN,
     1                    J, K )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C                DYNAMIC DIMENSION CONTROL FOR MODEL
C
C      NOTE: DYNDIM IS ESSENTIALLY WRITTEN BY PROGRAM DIMMAK.F
C            USING ARRAYS "REALS" AND "INTEGERS", THEN EDITED
C            TO REMOVE BLANKS, ETC.  IT ALSO WRITES MODEL CALL
C            AND DIMENSION STATEMENTS
C
C  WARNING: COMPILE WITH EXTRA CONTINUE CARD OPTION -NL40
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 RN, IN
      PARAMETER ( MAXTYP=3)
      DIMENSION  TITLE(15), R(MAXR), RN(NUMR), I(MAXI), IN(NUMI),
     1           J(NUMR), K(NUMI)
C
C     COMMON / REAL / R, RN, MMAXR, NNUMR, LLASTR, J
C     COMMON / INTEGER / MMAXI, NNUMI, LLASTI, IN, K
C
C     I      = VECTOR HOLDING ALL INTEGER ARRAYS (APPENDABLE)
C     IN     = NAMES OF EACH INTEGER ARRAY (APPENDABLE)
C     J      = POINTER TO BEGINNING OF EACH REAL ARRAY (APPENDABLE)
C     K      = POINTER TO BEGINNING OF EACH INTEGER ARRAY (APPENDABLE)
C     LASTI  = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY
C     LASTR  = NUMBER OF THE LAST ASSIGNED REAL ARRAY
C     LLASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY (COMMON)
C     LLASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY (COMMON)
C     MAXI   = STORAGE ALLOWED FOR ALL INTEGER ARRAYS
C     MAXR   = STORAGE ALLOWED FOR ALL REAL ARRAYS
C     MMAXI  = STORAGE ALLOWED FOR ALL INTEGER ARRAYS (COMMON)
C     MMAXR  = STORAGE ALLOWED FOR ALL REAL ARRAYS (COMMON)
C     NNUMI  = ALLOWED NUMBER OF INTEGER ARRAYS (VIA COMMON)
C     NNUMR  = ALLOWED NUMBER OF REAL ARRAYS (VIA COMMON)
C     NUMI   = ALLOWED NUMBER OF INTEGER ARRAYS
C     NUMR   = ALLOWED NUMBER OF REAL ARRAYS
C     R      = VECTOR HOLDING ALL REAL ARRAYS (APPENDABLE)
C     RN     = NAMES OF EACH REAL ARRAY (APPENDABLE)
C
C       ** READ APPLICATION CONTROL DATA **
C        1         2         3         4         5         6         712
C23456789012345678901234567890123456789012345678901234567890-----------X
      CALL  CONTROL (TITLE, M, NE, NG, N, NSPACE, NSEG, LBN, NITER, 
     1        NCURVE, INRHS, ISAY, NNPFIX, NNPFLO, NLPFIX, NLPFLO, 
     2        MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, NTAPE1, 
     3        NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, NDFREE, NELFRE, 
     4        NFLUX, IPTEST, LPTEST, NRB, NQP, LSHAPE, NLTYPE, MODE, 
     5        IBUG, NBSFIX,  NBSFLO, NGF)
C
C      SET ADVANCED USER DEFAULTS
      NC     = N
      NCOEFF = NDFREE*2
      NF     = NGF
      NGEOM  = N
      NPARM  = NSPACE
      NPLT   = 0
      NTMP   = 0
      NOMAT  = NLTYPE
      J(1)   = 1
      K(1)   = 1 
c     write(6,*) k
C   ---  Calculate real array pointers  ---
C   REAL    1, sys pt coords  
       RN(  1)  =  "X         "
        J(  2)  =  J(  1) + (M         )*(NSPACE    )*(1         )+0
C   ---  Calculate integer array pointers  ---
C INTEGER   1, all pts bc code
       IN(  1)  =  "IBC       "
        K(  2)  =  K(  1) + (M         )*(1         )*(1         )+0
C INTEGER   2, codes at a poin
       IN(  2)  =  "KODES     "
        K(  3)  =  K(  2) + (NG        )*(1         )*(1         )+0
C INTEGER   3, system topology
       IN(  3)  =  "NODES     "
        K(  4)  =  K(  3) + (NE        )*(N         )*(1         )+0
C INTEGER   4, no constrain ty
       IN(  4)  =  "NRES      "
        K(  5)  =  K(  4) + (MAXTYP    )*(1         )*(1         )+0
C INTEGER   5, el type flag   
       IN(  5)  =  "LTYPE     "
        K(  6)  =  K(  5) + (NE        )*(1         )*(1         )+0
C
C              INPUT NODES, BC FLAGS, ELEMENTS
C
C     CALL INPUT (M, N, NE, NG, NSPACE, X,       IBC,     NODES,  
C                 LTYPE,  NLTYPE)
      CALL INPUT (M, N, NE, NG, NSPACE, R(J(1)), I(K(1)), I(K(3)), 
     1            I(K(5)), NLTYPE)
C
C        COUNT BC AND CONSTRAINTS, CONVERT NRES TO NREQ
C
C     CALL CCOUNT (M, NG, NRES,    IBC,     KODES,   MAXACT, NUMCE, 
C    1             MAXTYP, NREQ )
c     fix NREQ below
      CALL CCOUNT (M, NG, I(K(4)), I(K(1)), I(K(2)), MAXACT, NUMCE, 
     1             MAXTYP, I(K(4)) )
      IF ( IBUG .GT. 0 )  THEN
        LOC1 = 1
        LOC2 = 5
        CALL LISTI (LOC1, LOC2, NEXTI, IN, K, I)
        LOC1 = 1
        LOC2 = 1
        CALL LISTR (LOC1, LOC2, NEXTR, RN, J, R)
      ENDIF
C
C   ---  CALCULATE REAL ARRAY POINTERS  ---
C
C   REAL    2, jacobian       
       RN(  2)  =  "AJ        "
        J(  3)  =  J(  2) + (NSPACE    )*(NSPACE    )*(1         )+0
C   REAL    3, inverse jacobia
       RN(  3)  =  "AJINV     "
        J(  4)  =  J(  3) + (NSPACE    )*(NSPACE    )*(1         )+0
C   REAL    4, real pt average
       RN(  4)  =  "AVE       "
        J(  5)  =  J(  4) + (M     +1  )*(NRB+2     )*(1         )+1
C   REAL    5, b matrix       
       RN(  5)  =  "B         "
        J(  6)  =  J(  5) + (NRB       )*(NELFRE    )*(1         )+0
C   REAL    6, body force     
       RN(  6)  =  "BODY      "
        J(  7)  =  J(  6) + (NSPACE    )*(1         )*(1         )+0
C   REAL    7, el load vector 
       RN(  7)  =  "C         "
        J(  8)  =  J(  7) + (NELFRE    )*(1         )*(1         )+0
C   REAL    8, sys load vector
       RN(  8)  =  "CC        "
        J(  9)  =  J(  8) + (NDFREE    )*(1         )*(1         )+0
C   REAL    9, constrain coeff
       RN(  9)  =  "CEQ       "
        J( 10)  =  J(  9) + (MAXACT    )*(NUMCE     )*(1         )+0
C   REAL   10, el or pt coord 
       RN( 10)  =  "COORD     "
        J( 11)  =  J( 10) + (N         )*(NSPACE    )*(1         )+0
C   REAL   11, el or pt dof   
       RN( 11)  =  "D         "
        J( 12)  =  J( 11) + (NELFRE    )*(1         )*(1         )+0
C   REAL   12, old sys dof    
       RN( 12)  =  "DDOLD     "
        J( 13)  =  J( 12) + (NDFREE    )*(1         )*(1         )+0
C   REAL   13, global deriv h 
       RN( 13)  =  "DGH       "
        J( 14)  =  J( 13) + (NSPACE    )*(N         )*(NQP   +2  )+1
C   REAL   14, local deriv g  
       RN( 14)  =  "DLG       "
        J( 15)  =  J( 14) + (NPARM     )*(NGEOM     )*(NQP   +2  )+1
C   REAL   15, local deriv h  
       RN( 15)  =  "DLH       "
        J( 16)  =  J( 15) + (NSPACE    )*(N         )*(NQP   +2  )+1
C   REAL   16, constitutive ma
       RN( 16)  =  "E         "
        J( 17)  =  J( 16) + (NRB       )*(NRB       )*(1         )+0
C   REAL   17, matrix product 
       RN( 17)  =  "EB        "
        J( 18)  =  J( 17) + (NRB       )*(NELFRE    )*(1         )+0
C   REAL   18, real el propert
       RN( 18)  =  "ELPROP    "
        J( 19)  =  J( 18) + (NLPFLO+1  )*(1         )*(1         )+1
C   REAL   19, real prop all e
       RN( 19)  =  "FLTEL     "
        J( 20)  =  J( 19) + (NE        )*(NLPFLO+1  )*(1         )+1
C   REAL   20, real prop segme
       RN( 20)  =  "FLTBS     "
        J( 21)  =  J( 20) + (NSEG  +1  )*(NBSFLO+1  )*(1         )+1
C   REAL   21, real misc prop 
       RN( 21)  =  "FLTMIS    "
        J( 22)  =  J( 21) + (MISCFL+1  )*(1         )*(1         )+1
C   REAL   22, real prop all p
       RN( 22)  =  "FLTNP     "
        J( 23)  =  J( 22) + (M         )*(NNPFLO+1  )*(1         )+1
C   REAL   23, flux comps on e
       RN( 23)  =  "FLUX      "
        J( 24)  =  J( 23) + (NF    +1  )*(1         )*(1         )+1
C   REAL   24, all flux on nod
       RN( 24)  =  "FLUXBS    "
        J( 25)  =  J( 24) + (NSEG  +1  )*(NFLUX +1  )*(1         )+1
C   REAL   25, geom interpolat
       RN( 25)  =  "G         "
        J( 26)  =  J( 25) + (NGEOM     )*(NQP   +2  )*(1         )+1
C   REAL   26, gauss pts 1-d  
       RN( 26)  =  "GPT       "
        J( 27)  =  J( 26) + (NQP   +1  )*(1         )*(1         )+1
C   REAL   27, gauss wts 1-d  
       RN( 27)  =  "GWT       "
        J( 28)  =  J( 27) + (NQP   +1  )*(1         )*(1         )+1
C   REAL   28, solution interp
       RN( 28)  =  "H         "
        J( 29)  =  J( 28) + (N         )*(NQP   +2  )*(1         )+1
C   REAL   29, integral of h  
       RN( 29)  =  "HINTG     "
        J( 30)  =  J( 29) + (N         )*(NQP+3     )*(1         )+0
C   REAL   30, plotter data   
       RN( 30)  =  "PLTSET    "
        J( 31)  =  J( 30) + (NPLT  +1  )*(1         )*(1         )+1
C   REAL   31, real prop el no
       RN( 31)  =  "PRTLPT    "
        J( 32)  =  J( 31) + (N         )*(NNPFLO+1  )*(1         )+1
C   REAL   32, real mat numb p
       RN( 32)  =  "PRTMAT    "
        J( 33)  =  J( 32) + (NLPFLO+1  )*(NOMAT +1  )*(1         )+1
C   REAL   33, quadrature coor
       RN( 33)  =  "PT        "
        J( 34)  =  J( 33) + (NPARM     )*(NQP +1    )*(1         )+0
C   REAL   34, dof max min val
       RN( 34)  =  "RANGE     "
        J( 35)  =  J( 34) + (NG        )*(2         )*(1         )+0
C   REAL   35, el or edge sq m
       RN( 35)  =  "S         "
        J( 36)  =  J( 35) + (NELFRE    )*(NELFRE    )*(1         )+0
C   REAL   36, stress at el po
       RN( 36)  =  "SATPT     "
        J( 37)  =  J( 36) + (NRB+2     )*(N         )*(1         )+0
C   REAL   37, strain or grad 
       RN( 37)  =  "STRAIN    "
        J( 38)  =  J( 37) + (NRB+2     )*(1         )*(1         )+0
C   REAL   38, initial strain 
       RN( 38)  =  "STRAN0    "
        J( 39)  =  J( 38) + (NRB       )*(1         )*(1         )+0
C   REAL   39, stress + rms or
       RN( 39)  =  "STRESS    "
        J( 40)  =  J( 39) + (NRB+2     )*(1         )*(1         )+0
C   REAL   40, sys control dat
       RN( 40)  =  "SYSDAT    "
        J( 41)  =  J( 40) + (NSYS  +1  )*(1         )*(1         )+1
C   REAL   41, temporary work 
       RN( 41)  =  "TMP       "
        J( 42)  =  J( 41) + (NTMP  +1  )*(1         )*(1         )+1
C   REAL   42, values at corne
       RN( 42)  =  "VALC      "
        J( 43)  =  J( 42) + (NRB       )*(NC    +1  )*(1         )+1
C   REAL   43, values on edge 
       RN( 43)  =  "VALE      "
        J( 44)  =  J( 43) + (NRB       )*(NC    +1  )*(1         )+1
C   REAL   44, quadrature weig
       RN( 44)  =  "WT        "
        J( 45)  =  J( 44) + (NQP +1    )*(1         )*(1         )+0
C   REAL   45, xy ends of a li
       RN( 45)  =  "XPT       "
        J( 46)  =  J( 45) + (NSPACE    )*(2         )*(1         )+0
C   REAL   46, global of gauss
       RN( 46)  =  "XYZ       "
        J( 47)  =  J( 46) + (NSPACE    )*(1         )*(1         )+0
C   REAL   47, sys answers    
       RN( 47)  =  "DD        "
        J( 48)  =  J( 47) + (NDFREE    )*(1         )*(1         )+0
C   REAL   48, elem post process
       RN( 48)  =  "USEREL    "
        J( 49)  =  J( 48) + (NG        )*(N         )*(1         )+0
C   REAL   49, pt post process
       RN( 49)  =  "USERPT    "
        J( 50)  =  J( 49) + (NG        )*(1         )*(1         )+0
C   REAL   50, sys square matr
       RN( 50)  =  "SS        "
        J( 51)  =  J( 50) + (NCOEFF    )*(1         )*(1         )+0
       LASTR = J(51)
       NEXTR = 51
       IF ( NEXTR .GT. NUMR ) THEN
         WRITE (6,*) 'IN DRIVER, SET NUMR > ', NEXTR
         STOP        'IN DRIVER, INCREASE NUMR'
       ENDIF
C
C   ---  CALCULATE INTEGER ARRAY POINTERS  ---
C
C INTEGER   6, pt ave counter 
       IN(  6)  =  "IADD      "
        K(  7)  =  K(  6) + (M     +1  )*(1         )*(1         )+1
C INTEGER   7, skyline diagona
       IN(  7)  =  "IDIAG     "
        K(  8)  =  K(  7) + (NDFREE    )*(1         )*(1         )+0
C INTEGER   8, dof index pt or
       IN(  8)  =  "INDEX     "
        K(  9)  =  K(  8) + (NELFRE    )*(1         )*(1         )+0
C INTEGER   9, el where pt is 
       IN(  9)  =  "LFIRST    "
        K( 10)  =  K(  9) + (M         )*(1         )*(1         )+0
C INTEGER  10, el where pt is 
       IN( 10)  =  "LLAST     "
        K( 11)  =  K( 10) + (M         )*(1         )*(1         )+0
C INTEGER  11, el or edge topo
       IN( 11)  =  "LNODE     "
        K( 12)  =  K( 11) + (N         )*(1         )*(1         )+0
C INTEGER  12, integer prop al
       IN( 12)  =  "LPFIX     "
        K( 13)  =  K( 12) + (NE        )*(NLPFIX+1  )*(1         )+1
C INTEGER  13, fixed prop segm
       IN( 13)  =  "NBSPFX    "
        K( 14)  =  K( 13) + (NSEG  +1  )*(NBSFIX+1  )*(1         )+1
C INTEGER  14, pts of el fix p
       IN( 14)  =  "LPPROP    "
        K( 15)  =  K( 14) + (NNPFIX+1  )*(1         )*(1         )+1
C INTEGER  15, el integer prop
       IN( 15)  =  "LPROP     "
        K( 16)  =  K( 15) + (NLPFIX+1  )*(1         )*(1         )+1
C INTEGER  16, data for el typ
       IN( 16)  =  "LTDATA    "
        K( 17)  =  K( 16) + (6         )*(NLTYPE    )*(1         )+0
C INTEGER  17, integer misc pr
       IN( 17)  =  "MISFIX    "
        K( 18)  =  K( 17) + (MISCFX+1  )*(1         )*(1         )+1
C INTEGER  18, constraint inde
       IN( 18)  =  "NDXC      "
        K( 19)  =  K( 18) + (MAXACT    )*(NUMCE     )*(1         )+0
C INTEGER  19, all nodes w flu
       IN( 19)  =  "NODEF     "
        K( 20)  =  K( 19) + (NSEG  +1  )*(LBN   +1  )*(1         )+1
C INTEGER  20, nodes of max mi
       IN( 20)  =  "NRANGE    "
        K( 21)  =  K( 20) + (NG        )*(2         )*(1         )+0
C INTEGER  21, no constrain ty
       IN( 21)  =  "NREQ      "
        K( 22)  =  K( 21) + (MAXTYP    )*(1         )*(1         )+0
c       fix from ccount, on next dimmak run move NREQ after NRES
        do 123 ijk = 1,maxtyp
  123  i(k(21)+ijk-1) = i(k(4)+ijk-1)
C INTEGER  22, sys pts fix pro
       IN( 22)  =  "NPFIX     "
        K( 23)  =  K( 22) + (M         )*(NNPFIX+1  )*(1         )+1
C INTEGER  23, el col heights
       IN( 23)  =  "LHIGH     "
        K( 24)  =  K( 23) + (NELFRE    )*(1         )*(1         )+0
       LASTI = K(24)
       NEXTI = 24
       IF ( NEXTI .GT. NUMI ) THEN
         WRITE (6,*) 'IN DRIVER, SET NUMI > ', NEXTI
         STOP        'IN DRIVER, INCREASE NUMI'
       ENDIF
      IF ( IBUG .GT. 0 )  THEN
        LOC1 = 1
        LOC2 = 5
        CALL LISTI (LOC1, LOC2, NEXTI, IN, K, I)
        LOC1 = 1
        LOC2 = 1
        CALL LISTR (LOC1, LOC2, NEXTR, RN, J, R)
      ENDIF
C            --------------------------
C        --- Call the real main program ---
C            --------------------------
C
C     CALL  MODEL92 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI,
C    1      NEXTR, NEXTI, R, RN, I, IN, J, K,
C    A      TITLE, NSEG, LBN, NITER, NCURVE, INRHS, ISAY, NNPFIX, 
C    2      NLPFIX, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, 
C    3      NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, MAXTYP, 
C    4      NLTYPE, NUMCE, IPTEST, LPTEST, MODE, M, MAXACT, MISCFL, 
C    5      MISCFX, N, NC, NCOEFF, NDFREE, NE, NELFRE, NGF, NFLUX, 
C    6      NG, NGEOM, NLPFLO, NNPFLO, NOMAT, NPARM, NPLT, NQP, NRB, 
C    7      NSEG, NSPACE, NSYS, NTMP, NUMCE, LSHAPE, IBUG,
C    8      NBSFIX, NBSFLO,
C    9      X, AJ, AJINV, AVE, B, 
C    1      BODY, C, CC, CEQ, COORD, 
C    2      D, DDOLD, DGH, DLG, DLH, 
C    3      E, EB, ELPROP, FLTEL, FLTBS,
C    4      FLTMIS, FLTNP, FLUX, FLUXBS, G, 
C    5      GPT, GWT, H, HINTG, PLTSET, 
C    6      PRTLPT, PRTMAT, PT, RANGE, S, 
C    7      SATPT, STRAIN, STRAN0, STRESS, SYSDAT, 
C    8      TMP, VALC, VALE, WT, XPT, 
C    9      XYZ, DD, USEREL, USERPT, SS,
C    1      IBC, KODES, NODES, NRES, LTYPE, 
C    2      IADD, IDIAG, INDEX, LFIRST, LLAST, 
C    3      LNODE, LPFIX, NBSPFX, LPPROP, LPROP,
C    4      LTDATA, MISFIX, NDXC, NODEF, NRANGE, 
C    5      NREQ, NPFIX, LHIGH )
      CALL  MODEL92 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI,
     1      NEXTR, NEXTI, R, RN, I, IN, J, K,
     2      TITLE, NSEG, LBN, NITER, NCURVE, INRHS, ISAY, NNPFIX, 
     3      NLPFIX, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, 
     4      NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, MAXTYP, 
     5      NLTYPE, NUMCE, IPTEST, LPTEST, MODE, M, MAXACT, MISCFL, 
     6      MISCFX, N, NC, NCOEFF, NDFREE, NE, NELFRE, NGF, NFLUX, 
     7      NG, NGEOM, NLPFLO, NNPFLO, NOMAT, NPARM, NPLT, NQP, NRB, 
     8      NSEG, NSPACE, NSYS, NTMP, NUMCE, LSHAPE, IBUG,
     9      NBSFIX, NBSFLO,
     1      R(J(  1)), R(J(  2)), R(J(  3)), R(J(  4)), R(J(  5)),
     2      R(J(  6)), R(J(  7)), R(J(  8)), R(J(  9)), R(J( 10)),
     3      R(J( 11)), R(J( 12)), R(J( 13)), R(J( 14)), R(J( 15)),
     4      R(J( 16)), R(J( 17)), R(J( 18)), R(J( 19)), R(J( 20)),
     5      R(J( 21)), R(J( 22)), R(J( 23)), R(J( 24)), R(J( 25)),
     6      R(J( 26)), R(J( 27)), R(J( 28)), R(J( 29)), R(J( 30)),
     7      R(J( 31)), R(J( 32)), R(J( 33)), R(J( 34)), R(J( 35)),
     8      R(J( 36)), R(J( 37)), R(J( 38)), R(J( 39)), R(J( 40)),
     9      R(J( 41)), R(J( 42)), R(J( 43)), R(J( 44)), R(J( 45)),
     1      R(J( 46)), R(J( 47)), R(J( 48)), R(J( 49)), R(J( 50)), 
     2      I(K(  1)), I(K(  2)), I(K(  3)), I(K(  4)), I(K(  5)),
     3      I(K(  6)), I(K(  7)), I(K(  8)), I(K(  9)), I(K( 10)),
     4      I(K( 11)), I(K( 12)), I(K( 13)), I(K( 14)), I(K( 15)),
     5      I(K( 16)), I(K( 17)), I(K( 18)), I(K( 19)), I(K( 20)),
     6      I(K( 21)), I(K( 22)), I(K( 23)))
      RETURN
      END
      SUBROUTINE  ELBAND (N, NG, IBW, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C             ELEMENT BANDWIDTH CALCULATION
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  LNODE(N)
C     LNODE = ELEMENT INCIDENCES
C     N     = NUMBER OF NODES PER ELEMENT
C     NG    = NUMBER OF PARAMETERS PER NODE
C     IBW   = UPPER HALF BANDWIDTH, INCLUDING DIAGONAL
      IBW = 1
      NLESS = N - 1
      DO 20 I = 1, NLESS
        II = I + 1
        LNI = LNODE(I)
C        ALLOW FOR OMITTED NODES
        IF ( LNI .GT. 0 )  THEN 
          DO 10  J = II, N
            LNJ = LNODE(J)
            IF ( LNJ .GT. 0 )  THEN 
              NEW = NG*( IABS( LNJ-LNI ) + 1)
              IF ( NEW .GT. IBW ) IBW = NEW
            ENDIF
 10       CONTINUE
        ENDIF
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  ELCOL (N, NSPACE, NELFRE, NRB, NQP, NGEOM,
     1    NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX,
     2    NLPFLO, COORD, C, H, DGH, B, E, EB, STRAIN,
     3    STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     4    AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     5    PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 
     6    NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C                 GENERATE ELEMENT COLUMN MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT   REAL*8  (A-H,O-Z)
C        ALWAYS USED
      DIMENSION  COORD(N,NSPACE), C(NELFRE)
C
C        USUALLY USED
      DIMENSION  H(N), DGH(NSPACE,N), B(NRB,NELFRE), 
     1           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     2           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE)
C
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION  PT(NPARM,NQP), WT(NQP), XYZ(NSPACE), DLH(NSPACE,N), 
     1           G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 
     2           AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N)
C
C        OPTIONAL PROPERTY AND SOLUTION VALUES
      DIMENSION  D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 
     1           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     2           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     3           LPPROP(0:NNPFIX)
C
C                     VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF FLOATING PT PROPERTIES
C     FLTMIS  = SYSTEM STORAGE OF FLOATING PT MISC PROP
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER POINT ELEMENT PROPERTIES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     WT      = QUADRATURE WEIGHTS
C     XYZ     = SPACE COORDINATES AT A POINT
C     .....................................................
C      ***  ELCOL PROBLEM DEPENDENT STATEMENTS FOLLOW ***
C     .....................................................
      RETURN
      END
      SUBROUTINE ELCORD (M,N,NSPACE,X,COORD,LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     DETERMINE COORDINATES OF NODES ON ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  X(M,NSPACE), COORD(N,NSPACE), LNODE(N)
C     M      = NUMBER OF NODES IN SYSTEM
C     NSPACE = DIMENSION OF SPACE
C     N      = NUMBER OF NODES PER ELEMENT
C     X      = COORDINATES OF SYSTEM NODES
C     COORD  = COORDINATES OF ELEMENT NODES
C     LNODE  = N ELEMENT INCIDENCES OF ELEMENT
      DO 20  K = 1, NSPACE
        DO 10  I = 1, N
C          ALLOW FOR OMITTED NODES
          IF ( LNODE(I) .GT. 0 ) 
     1      COORD(I,K) = X(LNODE(I),K)
 10     CONTINUE
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  ELFRE (NDFREE, NELFRE, D, DD, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT ELEMENT DEGREES OF FREEDOM FROM SYSTEM DOF
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  D(NELFRE), DD(NDFREE), INDEX(NELFRE)
C     D      = NODAL PARAMETERS ASSOCIATED
C     DD     = SYSTEM ARRAY OF NODAL PARAMETERS
C     INDEX  = ARRAY OF SYSTEM DEGREE OF FREEDOM NUMBERS
C     NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
      DO 10  I = 1, NELFRE
C        ALLOW FOR OMITTED NODES
        IF ( INDEX(I) .GT. 0 ) THEN
          D(I) = DD(INDEX(I))
        ELSE
          D(I) = 0.0
        ENDIF
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  ELHIGH (NELFRE,INDEX,LHIGH)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C      FIND SYSTEM COLUMN HEIGHTS OF AN ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  INDEX(NELFRE), LHIGH(NELFRE)
C     NELFRE   = NO OF DEGREES OF FREEDOM OF ELEMENT
C     INDEX    = SYSTEM DOF NOS OF ELEMENT PARAMETERS
C     LHIGH(I) = COLUMN HEIGHT FOR EQUATION INDEX(I)
      MIN = INDEX(1)
C      FIND MINIMUM INDEX
      DO 10  I = 1, NELFRE
        LHIGH(I) = 0
        NDX = INDEX(I)
C        ALLOW FOR OMITTED NODES
        IF ( NDX .GT. 0 .AND. NDX .LT. MIN ) MIN = NDX
 10   CONTINUE
C      CONVERT TO COLUMN HEIGHTS
      MIN = MIN - 1
      DO 20  I = 1, NELFRE
        NDX = INDEX(I)
        IF ( NDX .GT. 0 )  LHIGH(I) = NDX - MIN
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  ELPOST (N, NSPACE, NELFRE, NRB, NQP, NNPFIX, 
     1            NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, H, 
     2            DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 
     3            HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     4            PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 
     5            NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     GENERATE OR STORE DATA FOR ELEMENT POST-SOLUTION USE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT   REAL*8  (A-H,O-Z)
C        USUALLY USED
      DIMENSION  H(N), DGH(NSPACE,N), B(NRB,NELFRE), HINTG(N),
     1           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     2           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE), LNODE(N)
C
C        OPTIONAL PROPERTY AND SOLUTION VALUES
      DIMENSION  D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 
     1           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     2           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     3           LPPROP(0:NNPFIX)
C
C                     VARIABLES:
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF FLOATING PT PROPERTIES
C     FLTMIS  = SYSTEM STORAGE OF FLOATING PT MISC PROP
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER POINT ELEMENT PROPERTIES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     .....................................................
C      *** ELPOST PROBLEM DEPENDENT STATEMENTS FOLLOW ***
C     .....................................................
      RETURN
      END
      SUBROUTINE  ELPRTY (LID, LHOMO, NE, NLPFIX, NLPFLO, 
     1                    LPFIX, FLTEL, LPROP, ELPROP)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C          EXTRACT PROPERTIES OF A ELEMENT, LID, 
C            FROM TOTAL PROPERTIES ARRAYS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  FLTEL(NE,0:NLPFLO), ELPROP(0:NLPFLO),
     1           LPFIX(NE,0:NLPFIX), LPROP(0:NLPFIX)
C     LPFIX  = SYSTEM ARRAY OF FIXED PT ELEM PROPERTIES
C     LPROP  = ELEM FIXED PT PROPERTIES ARRAY
C     FLTEL  = SYS ARRAY OF FLOATING PT NODAL PROP
C     ELPROP = ELEM FLOATING PT PROPERTIES ARRAY
C     LHOMO  = 1, IF PROPERTIES ARE SAME IN ALL ELEMENTS
C     NLPFIX = NUMBER OF INTEGER ELEMENT PROPERTIES
C     NLPFLO = NUMBER OF REAL ELEMENT PROPERTIES
      IF ( LHOMO .EQ. 1 )  THEN
        I = 1
      ELSE
        I = LID
      ENDIF
C      FLOATING POINT PROPERTIES
      DO 10  J = 1, NLPFLO
 10   ELPROP(J) = FLTEL(I,J)
C      FIXED POINT PROPERTIES
      DO 20  J = 1, NLPFIX
 20   LPROP(J) = LPFIX(I,J)
      RETURN
      END
      SUBROUTINE  ELSQ (N, NSPACE, NELFRE, NRB, NQP, NGEOM,
     1    NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX,
     2    NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN,
     3    STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     4    AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     5    PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 
     6    NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG, IE )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT   REAL*8  (A-H,O-Z)
C        ALWAYS USED
      DIMENSION  COORD(N,NSPACE), S(NELFRE,NELFRE)
C
C        USUALLY USED
      DIMENSION  C(NELFRE), H(N), DGH(NSPACE,N), B(NRB,NELFRE), 
     1           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     2           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE)
C
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION  PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N), 
     1           G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 
     2           AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N),
     3           XYZ(NSPACE)
C
C        OPTIONAL PROPERTY AND SOLUTION VALUES
      DIMENSION  D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 
     1           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     2           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     3           LPPROP(0:NNPFIX)
C
C                     VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF FLOATING PT PROPERTIES
C     FLTMIS  = SYSTEM STORAGE OF FLOATING PT MISC PROP
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER POINT ELEMENT PROPERTIES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     WT      = QUADRATURE WEIGHTS
C     XYZ     = SPACE COORDINATES AT A POINT
C     .....................................................
C      ***  ELSQ PROBLEM DEPENDENT STATEMENTS FOLLOW ***
C     .....................................................
      RETURN
      END
      SUBROUTINE ERROR (NE, N, NG, NELFRE, NDFREE, NODES, LNODE, INDEX,
     1                  DD, D, M, AVE, NS, NM, NQ, H, X, NSPACE, ELAVE,
     2                  B, EHAT, ESTAR, EEL, ENORM, GNORM, IADD, ERRAVE,
     3                  SYSNOR, NTAPE )
C     ------------------------------------------------------------------
C     ELEMENT ERROR ESTIMATES FOR ADAPTIVE SOLUTIONS
C     ------------------------------------------------------------------
      DIMENSION  DD(NDFREE), D(NELFRE), NODES(NE,N), AVE(M,NS+2), H(N)
      DIMENSION  ELAVE (N,NS+2), B(NS,NELFRE), EHAT(NS), ESTAR(NS+2)
      DIMENSION  EEL(NS+2), ENORM(NE), X(M,NSPACE), LNODE(N)
      DIMENSION  INDEX(NELFRE)
C      THE FOLLOWING DIMENSIONS ARE FOR MOVIE.BYU SUBROUTINE
      DIMENSION  IADD(M), ERRAVE(M)
C....  METHOD: ERROR ESTIMATE BY USING THE NORM OF DIFFERENCE 
C....  BETWEEN  THE ELEMENT GRADIENT AND ITS NODAL AVERAGE GRADIENT.
C....  FOR STRESS ANALYSIS, GRADIENT MEANS STRESS "VECTOR".
C                          --- ARRAYS ---
C      AVE   = NODAL AVERAGED GRADIENT "VECTORS"
C      B     = B MATRIX IN STIFFNESS INTEGRAL
C      EEL   = VECTOR OF THE DIFFERENCE BETWEEN ESTAR AND EHAT
C      EHAT  = ARRAY CONTAINING THE VALUES OF THE DISCONTINUOUS
C              GRADIENTS AT THE QUADRATURE POINTS.
C      ELAVE = MATRIX CONTAINING THE VALUES OF THE NODAL 
C              AVERAGE GRADIENTS FOR AN ELEMENT. 
C      ENORM = THE ERROR L2 NORM FOR THE ELEMENT (RELATIVE)
C      ERRAVE= AVERAGE ERROR AT A NODE
C      ESTAR = ARRAY CONTAINING THE VALUES OF THE NODAL AVERAGE
C              GRADIENT AT THE QUADRATURE POINTS
C      GNORM = GLOBAL NORM
C      H     = ARRAY CONTAINING THE VALUES OF THE SHAPE FUNCTIONS
C              AT A QUADRATURE POINT
C      IADD  = NUMBER OF ELEMENTS CONNECTED TO A NODE
C      NS    = NUMBER OF STRAINS ( ROWS IN B , AND D )
C      SYSNOR= SYSTEM NORM. THE GRADIENT L2 NORM AS A ROOT MEAN
C              SQUARE OF ALL ELEMENTS
C
C....  INITIALIZING
      SYSNOR = 0.0
C....  REWIND THE FILE WITH THE DATA
      REWIND NTAPE
C....  LOOP OVER ELEMENTS TO FIND THE ERROR
      DO 50 IE = 1, NE
C....    EXTRACT D(NELFRE) ('PHI') AND ELAVE(N,NS) FOR THE ELEMENT
C....    FIND THE DEGREES OF FREEDOM FOR THIS ELEMENT
        CALL LNODES (IE, NE, N, NODES, LNODE)
        CALL INDXEL (N, NELFRE, NG, LNODE, INDEX)
        CALL ELFRE  (NDFREE, NELFRE, D, DD, INDEX)
C....    GET CONTRIBUTIONS FROM EACH COMPONENT OF THE GRADIENT 'AVE'
        DO 60 J = 1, NS
          CALL  ELFRE (M, N, ELAVE(1,J), AVE(1,J), LNODE)
 60     CONTINUE
C....    LOOP OVER QUADRATURE POINTS FOR CURRENT ELEMENT
        ENORM(IE) = 0.0
        GNORM     = 0.0
C....    READ THE NUMBER OF POINTS (WRITTEN IN ISOPAR.F)
        READ (NTAPE,*) NIP
        DO 70 IP = 1, NIP
C....      READ THE REQUIRED DATA :H,B,DETWT (WRITTEN IN ISOPAR.F)
          READ (NTAPE,1000) ( H(I),I=1,N)
 1000     FORMAT ( 6( 1X, 1PE12.5 ) )
          READ (NTAPE,1000) (( B(INS,I),INS=1,NS) ,I=1,NELFRE)
          READ (NTAPE,1000) DETWT
C....      GET PRODUCTS  ESTAR= E(TRANSP) H(TRANSP)
C....         EHAT =   B D  FOR HEAT AND
C....         DB D  FOR STRESS ANALYSIS
C....         AND SUBTRACT THEM: ESTAR-EHAT
          DO 80 J = 1, NS
            SUM1 = 0.0
            SUM2 = 0.0
            DO  90 IN = 1, NELFRE
              SUM2 = SUM2 + B(J,IN) * D(IN)
 90         CONTINUE
            DO  91 IN = 1, N
              SUM1 = SUM1 + ELAVE(IN,J) * H(IN)
 91         CONTINUE
            EHAT(J)  = SUM2
            ESTAR(J) = SUM1
            EEL(J)   = ESTAR(J) - EHAT(J)
 80       CONTINUE 
C....      FIND DOT PRODUCTS: SUM = EEL*EEL AND SUM2 = ESTAR*ESTAR
          SUM  = 0.0
          SUM2 = 0.0
          DO 100 J = 1, NS
            SUM2 = SUM2 + ESTAR(J)*ESTAR(J)
 100      SUM = SUM + EEL(J) * EEL(J)            
C....      UPDATE NORM OF ERROR & NORM OF GRADIENT (NUMER INTEGR.)
          ENORM(IE) = ENORM(IE) + SUM * DETWT
          GNORM     = GNORM + SUM2 * DETWT
 70     CONTINUE
        ENORM(IE) = SQRT( ENORM(IE) )
        GNORM     = SQRT( GNORM )
C
C....   THE FOLLOWING APPLY THE EMPIRICAL CORRELATION FACTOR
C....   AS SUGGESTED BY ZIENKIEWICZ
C....   THIS IS 1.1 FOR BILINEAR,1.3 FOR LINEAR TRIANGLES,1.6 
C....   FOR BIQUADRATIC AND 1.4 FOR QUADRATIC TRIANGLES
        IF ( N .EQ. 4 )  THEN
          FACTOR = 1.1
        ELSE IF ( N .EQ. 3 )  THEN
          FACTOR = 1.3
        ELSE IF ( N .EQ. 8 )  THEN
          FACTOR = 1.6
        ELSE IF ( N .EQ. 6 )  THEN
          FACTOR = 1.4
        ELSE
          FACTOR = 1.
        ENDIF
        ENORM(IE) = FACTOR*ENORM(IE)
C....    FINISHED APPLYING THE CORRELATION FACTOR
        SYSNOR = SYSNOR + GNORM
50    CONTINUE
C...   AVERAGE OVER ELEMENTS
      SYSNOR =  SYSNOR/NE
      PRINT*,'THE SYSTEM NORM (SYSNOR) IS',SYSNOR
C....  FIND THE RELATIVE ERRROR NORM ENORM FOR EACH ELEMENT
      DO 150 IE = 1, NE
        IF ( SYSNOR .NE. 0.0 ) THEN
          ENORM(IE) = (ENORM(IE)/SYSNOR)*100
          IF ( ENORM(IE) .GT. 0.05 ) THEN
            PRINT *,"THE ELEMENT #", IE," NEEDS ",
     1      "REFINEMENT. THE % ERROR EST. IS ", ENORM(IE)
          ELSE 
            WRITE (*,*) 'THE % ERROR ESTIM. (ENORM) ',
     1                  'FOR EL #',IE,' IS', ENORM(IE)
          ENDIF
        ELSE
          PRINT *,'ERROR: SYSNOR IS EQUAL TO ZERO'
        ENDIF
150   CONTINUE
C....  CREATE A MOVIE.BYU FILE FOR VIEWING THE ELEMENTS ETC
C     CALL  MOVIE (N,M,NE,X,NODES,DD,ENORM,LNODE,IADD,ERRAVE)
      RETURN
      END
      SUBROUTINE  FACTOR (NDFREE, IBW, S)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LDLT FACTOR OF BANDED SYMMETRIC SQUARE MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  S(NDFREE,IBW)
C     NDFREE = MAX. DEGREES OF FREEDOM OF SYSTEM
C     IBW    = MAXIMUM HALF BANDWIDTH OF SYSTEM EQS
C     S      = RECT MATRIX WITH UPPER HALF BAND OF SYS EQS
      TEMP = 1.0/S(1,1)
      DO 10 J = 2,IBW
 10   S(1,J) = S(1,J)*TEMP
      DO 40  I = 2,NDFREE
        LL = I - 1
        NN = NDFREE - LL
        IF (NN .GT. IBW) NN = IBW
        DO 30 J = 1,NN
          L = IBW - J
          SUM = 0.0
C          ALLOW FOR OMITTED NODES
          IF ( L .GT. 0 ) THEN
            IF ( LL .LT. L ) L = LL
            DO 20 K = 1,L
              K1 = I - K
              K2 = 1 + K
              K3 = J + K
 20         SUM = SUM + S(K1,K2)*S(K1,K3)*S(K1,1)
          ENDIF
        S(I,J) = S(I,J) - SUM
        IF ( J .GT. 1 )  S(I,J) = S(I,J) / S(I,1)
 30     CONTINUE
 40   CONTINUE
      RETURN
      END
      SUBROUTINE  FULFAC (NDFREE, S)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     CROUT FACTORIZATION OF FULL EQS, S = L*D*LT
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  S(NDFREE,NDFREE)
C     D      = DIAGONAL MATRIX STORED ON S
C     L      = LOWER TRIANGULAR MATRIX STORED ON S
C     NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM
C     S      = ORIGINAL FULL SYMMETRIC MATRIX
C     NOTE: INEFFICIENT STORAGE, ONLY UPPER TRI USED
C      D1 = S11 BY DEFAULT
      DO 40  I = 2, NDFREE
        DO 20  J = 1, (I - 1)
          SUM = 0.D0
          IF ( J .GT. 1 )  THEN
C            FACTOR COLUMN
            DO 10  K = 1,(J - 1)
  10        SUM = SUM + S(K,K)*S(I,K)*S(J,K)
          ENDIF
  20    S(I,J) = ( S(I,J) - SUM )/S(J,J)
C        FACTOR DIAGONAL
        SUM = 0.D0
        DO 30  K = 1,(I - 1)
  30    SUM = SUM + S(K,K)*S(I,K)**2
  40  S(I,I) = S(I,I) - SUM
      RETURN
      END
      SUBROUTINE  FULSOL (NDFREE, S, C, D)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     FORWARD, BACK CROUT SUBSTITUTION FOR D, S*D = C
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  S(NDFREE,NDFREE), C(NDFREE), D(NDFREE)
C     C      = SOURCE OR FORCE VECTOR
C     D      = SOLUTION VECTOR, RETURNED 
C     DIA    = DIAGONAL MATRIX STORED ON S 
C     L      = LOWER TRIANGULAR MATRIX STORED ON S
C     NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM
C     S      = FULL FACTORED MATRIX OF L*DIA*L^T
C      FORWARD SUBSTITUTION
      DO 20  I = 1, NDFREE
        SUM = 0.D0
        IF ( I .GT. 1 )  THEN
          DO 10  K = 1,(I - 1)
  10      SUM = SUM + D(K)*S(I,K)
        ENDIF
  20  D(I) = C(I) - SUM
C      BACK SUBSTITUTION
      DO 40  I = NDFREE,1,-1
        SUM = 0.D0
        IF ( I .LT. NDFREE )  THEN
          DO 30  K = 1,(NDFREE-I)
  30      SUM = SUM + D(I+K)*S(I+K,I)
        ENDIF
  40  D(I) = D(I)/S(I,I) - SUM
      RETURN
      END
      SUBROUTINE  GAUS1D (NQP, GPT, GWT, NIP, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT 1-D GAUSS DATA FROM TABLES
C     * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION PT(1,0:NIP), WT(0:NIP), GPT(0:NIP), 
     1          GWT(0:NIP)
      NGP = NQP
      IF ( NGP .NE. NIP )  THEN
        NGP = NIP
        WRITE(6,*) 'WARNING, DATA CHANGED IN GAUS1D',
     1              NQP, NIP, NGP
      ENDIF
      CALL GAUSCO (NGP,GPT,WT)
      DO 10  IG = 1, NGP
        PT(1,IG) = GPT(IG)
  10  CONTINUE
      RETURN
      END
      SUBROUTINE  GAUS2D (NQP, GPT, GWT, NIP, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C          USE 1-D GAUSSIAN DATA TO GENERATE
C            QUADRATURE DATA FOR A SQUARE
C     * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION GPT(0:NIP), GWT(0:NIP), PT(2,0:NIP), 
     1          WT(0:NIP)
C     NQP = NUMBER OF TABULATED 1-D POINTS
C     NIP = NQP*NQP = NUMBER OF 2-D POINTS
C     GPT = TABULATED 1-D QUADRATURE POINTS
C     GWT = TABULATED 1-D QUADRATURE WEIGHTS
C     PT  = CALCULATED COORDS IN A SQUARE
C     WT  = CALCULATED WEIGHTS IN A SQUARE
      NGP = NQP
      IF ( (NGP*NGP) .NE. NIP )  THEN
        NGP = SQRT( FLOAT(NIP) ) + 0.1
        WRITE (6,*) 'WARNING, DATA CORRECTED, GAUS2D',
     1               NQP, NIP, NGP
      ENDIF
C      GET DATA FROM TABLE
c     write(6,*) 'in 2d before gausco'
c     write(6,*)'ngp,nqp,nip',ngp,nqp,nip
      CALL  GAUSCO (NGP,GPT,GWT)
c     write(6,*) 'in 2d after gausco'
c     write(6,*)'ngp,nqp,nip',ngp,nqp,nip
      K = 0
C      LOOP OVER GENERATED POINTS
      DO 20  I = 1,NGP
        DO 10  J = 1,NGP
          K = K + 1
          WT(K) = GWT(I)*GWT(J)
          PT(1,K) = GPT(J)
   10   PT(2,K) = GPT(I)
   20 CONTINUE
c     write(6,*) 'in 2d before exit '
c     write(6,*)'ngp,nqp,nip',ngp,nqp,nip
      RETURN
      END
      SUBROUTINE  GAUS3D (NQP, GPT, GWT, NIP, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C         USE 1-D GAUSSIAN DATA TO GENERATE
C           QUADRATURE DATA FOR A CUBE
C     * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION GPT(0:NIP), GWT(0:NIP), PT(3,0:NIP), 
     1          WT(0:NIP)
C     NQP = NUMBER OF TABULATED 1-D POINTS
C     NIP = NQP**3 = NUMBER OF 3-D POINTS
C     GPT = TABULATED 1-D QUADRATURE POINTS
C     GWT = TABULATED 1-D QUADRATURE WEIGHTS
C     PT  = CALCULATED COORDS IN A CUBE  
C     WT  = CALCULATED WEIGHTS IN A CUBE  
      NGP  = NQP
      NGP3 = NGP*NGP*NGP
      IF ( NGP3 .NE. NIP )  THEN
        NGP  = ( FLOAT( NIP ) )**(1./3.)
        WRITE (6,*) 'WARNING, DATA CHANGED IN GAUS3D',
     1               NQP, NIP, NGP
      ENDIF
C      GET TABLE DATA
      CALL  GAUSCO (NGP,GPT,GWT)
      K = 0
C      LOOP OVER GENERATED POINTS
      DO 30  L = 1,NGP
        DO 20  I = 1,NGP
          DO 10  J = 1,NGP
            K = K + 1
            WT(K) = GWT(I)*GWT(J)*GWT(L)
            PT(1,K) = GPT(J)
            PT(2,K) = GPT(I)
   10     PT(3,K) = GPT(L)
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  GAUSCO (NQP, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     GAUSSIAN QUADRATURE ABSCISSAE AND WEIGHT COEFFS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT  REAL*8   PT, WT
CQP   IMPLICIT  REAL*16  PT, WT
      PARAMETER ( NMAX = 12 )
      DIMENSION  PT(0:NQP), WT(0:NQP)
C     NQP  = NO. OF GAUSS POINTS IN ONE DIMENSION
C     PT   = ABSCISSAE OF GAUSS POINTS
C     WT   = WEIGHTS  OF GAUSS POINTS
C     NMAX = MAX. NO. OF POINTS TABULATED HEREIN
      NGP = NQP
      IF ( NGP .GT. NMAX )  THEN
        NGP = NMAX
        WRITE (6,*) 'WARNING, GAUSCO USED NGP = ', NMAX
      ENDIF 
      IF ( NGP .LT. 1 ) STOP 'NO POINTS IN GAUSCO'
      IF ( NGP .EQ. 1 )  THEN
C      NGP =  1, PRECISION =  1
        PT( 1) = 0.000000000000000000000000D+00
        WT( 1) = 0.20000000000000000000000D+01
        RETURN
      ELSEIF ( NGP .EQ. 2 )  THEN
C      NGP =  2, PRECISION =  3
        PT( 1) = -.577350269189625764509149D+00
        PT( 2) = 0.577350269189625764509149D+00
        WT( 1) = 0.10000000000000000000000D+01
        WT( 2) = 0.10000000000000000000000D+01
        RETURN
      ELSEIF ( NGP .EQ. 3 )  THEN
C      NGP =  3, PRECISION =  5
        PT( 1) = -.774596669241483377035835D+00
        PT( 2) = 0.000000000000000000000000D+00
        PT( 3) = 0.774596669241483377035835D+00
        WT( 1) = 0.55555555555555555555556D+00
        WT( 2) = 0.88888888888888888888889D+00
        WT( 3) = 0.55555555555555555555556D+00
c       write (6,*) 'in gausco'
c       write (6,*) pt
c       write (6,*) wt
c       call rprint (pt,1,nqp+1,0)
c       call rprint (wt,1,nqp+1,0)
        RETURN
      ELSEIF ( NGP .EQ. 4 )  THEN
C      NGP =  4, PRECISION =  7
        PT( 1) = -.861136311594052575223946D+00
        PT( 2) = -.339981043584856264802666D+00
        PT( 3) = 0.339981043584856264802666D+00
        PT( 4) = 0.861136311594052575223946D+00
        WT( 1) = 0.34785484513745385737306D+00
        WT( 2) = 0.65214515486254614262694D+00
        WT( 3) = 0.65214515486254614262694D+00
        WT( 4) = 0.34785484513745385737306D+00
        RETURN
      ELSEIF ( NGP .EQ. 5 )  THEN
C      NGP =  5, PRECISION =  9
        PT( 1) = -.906179845938663992797627D+00
        PT( 2) = -.538469310105683091036314D+00
        PT( 3) = 0.000000000000000000000000D+00
        PT( 4) = 0.538469310105683091036314D+00
        PT( 5) = 0.906179845938663992797627D+00
        WT( 1) = 0.23692688505618908751426D+00
        WT( 2) = 0.47862867049936646804129D+00
        WT( 3) = 0.56888888888888888888889D+00
        WT( 4) = 0.47862867049936646804129D+00
        WT( 5) = 0.23692688505618908751426D+00
        RETURN
      ELSEIF ( NGP .EQ. 6 )  THEN
        PT( 1) = -.932469514203152027812302D+00
        PT( 2) = -.661209386466264513661400D+00
        PT( 3) = -.238619186083196908630502D+00
        PT( 4) = 0.238619186083196908630502D+00
        PT( 5) = 0.661209386466264513661400D+00
        PT( 6) = 0.932469514203152027812302D+00
        WT( 1) = 0.17132449237917034504030D+00
        WT( 2) = 0.36076157304813860756983D+00
        WT( 3) = 0.46791393457269104738987D+00
        WT( 4) = 0.46791393457269104738987D+00
        WT( 5) = 0.36076157304813860756983D+00
        WT( 6) = 0.17132449237917034504030D+00
      ELSEIF ( NGP .EQ. 7 )  THEN
C      NGP =  7, PRECISION = 13
        PT( 1) = -.949107912342758524526190D+00
        PT( 2) = -.741531185599394439863865D+00
        PT( 3) = -.405845151377397166906607D+00
        PT( 4) = 0.000000000000000000000000D+00
        PT( 5) = 0.405845151377397166906607D+00
        PT( 6) = 0.741531185599394439863865D+00
        PT( 7) = 0.949107912342758524526190D+00
        WT( 1) = 0.12948496616886969327061D+00
        WT( 2) = 0.27970539148927666790147D+00
        WT( 3) = 0.38183005050511894495037D+00
        WT( 4) = 0.41795918367346938775510D+00
        WT( 5) = 0.38183005050511894495037D+00
        WT( 6) = 0.27970539148927666790147D+00
        WT( 7) = 0.12948496616886969327061D+00
        RETURN
      ELSEIF ( NGP .EQ. 8 )  THEN
C      NGP =  8, PRECISION = 15
        PT( 1) = -.960289856497536231683561D+00
        PT( 2) = -.796666477413626739591554D+00
        PT( 3) = -.525532409916328985817739D+00
        PT( 4) = -.183434642495649804939476D+00
        PT( 5) = 0.183434642495649804939476D+00
        PT( 6) = 0.525532409916328985817739D+00
        PT( 7) = 0.796666477413626739591554D+00
        PT( 8) = 0.960289856497536231683561D+00
        WT( 1) = 0.10122853629037625915253D+00
        WT( 2) = 0.22238103445337447054436D+00
        WT( 3) = 0.31370664587788728733796D+00
        WT( 4) = 0.36268378337836198296515D+00
        WT( 5) = 0.36268378337836198296515D+00
        WT( 6) = 0.31370664587788728733796D+00
        WT( 7) = 0.22238103445337447054436D+00
        WT( 8) = 0.10122853629037625915253D+00
        RETURN
      ELSEIF ( NGP .EQ. 9 )  THEN
C      NGP =  9, PRECISION = 17
        PT( 1) = -.968160239507626089835576D+00
        PT( 2) = -.836031107326635794299430D+00
        PT( 3) = -.613371432700590397308702D+00
        PT( 4) = -.324253423403808929038538D+00
        PT( 5) = 0.000000000000000000000000D+00
        PT( 6) = 0.324253423403808929038538D+00
        PT( 7) = 0.613371432700590397308702D+00
        PT( 8) = 0.836031107326635794299430D+00
        PT( 9) = 0.968160239507626089835576D+00
        WT( 1) = 0.081274388361574411971890D+00
        WT( 2) = 0.18064816069485740405847D+00
        WT( 3) = 0.26061069640293546231874D+00
        WT( 4) = 0.31234707704000284006863D+00
        WT( 5) = 0.33023935500125976316453D+00
        WT( 6) = 0.31234707704000284006863D+00
        WT( 7) = 0.26061069640293546231874D+00
        WT( 8) = 0.18064816069485740405847D+00
        WT( 9) = 0.08127438836157441197189D+00
        RETURN
      ELSEIF ( NGP .EQ. 10 )  THEN
C      NGP = 10, PRECISION = 19
        PT( 1) = -.973906528517171720077964D+00
        PT( 2) = -.865063366688984510732097D+00
        PT( 3) = -.679409568299024406234327D+00
        PT( 4) = -.433395394129247190799266D+00
        PT( 5) = -.148874338981631210884826D+00
        PT( 6) = 0.148874338981631210884826D+00
        PT( 7) = 0.433395394129247190799266D+00
        PT( 8) = 0.865063366688984510732097D+00
        PT( 9) = 0.679409568299024406234327D+00
        PT(10) = 0.973906528517171720077964D+00
        WT( 1) = 0.066671344308688137593570D+00
        WT( 2) = 0.14945134915058059314578D+00
        WT( 3) = 0.21908636251598204399554D+00
        WT( 4) = 0.26926671930999635509123D+00
        WT( 5) = 0.29552422471475287017389D+00
        WT( 6) = 0.29552422471475287017389D+00
        WT( 7) = 0.26926671930999635509123D+00
        WT( 8) = 0.14945134915058059314578D+00
        WT( 9) = 0.21908636251598204399554D+00
        WT(10) = 0.06667134430868813759357D+00
        RETURN
      ELSEIF ( NGP .EQ. 11 )  THEN
C      NGP = 11, PRECISION = 21
        PT( 1) = -.987228658146056992803938D+00
        PT( 2) = -.887062599768095299075158D+00
        PT( 3) = -.730152005574049324093416D+00
        PT( 4) = -.519096129206811815925726D+00
        PT( 5) = -.269543155952344972331532D+00
        PT( 6) = 0.000000000000000000000000D+00
        PT( 7) = 0.269543155952344972331532D+00
        PT( 8) = 0.519096129206811815925726D+00
        PT( 9) = 0.730152005574049324093416D+00
        PT(10) = 0.887062599768095299075158D+00
        PT(11) = 0.987228658146056992803938D+00
        WT( 1) = 0.055668567116173666482750D+00
        WT( 2) = 0.12558036946490462463469D+00
        WT( 3) = 0.18629021092773425142610D+00
        WT( 4) = 0.23319376459199047991852D+00
        WT( 5) = 0.26280454451024666218069D+00
        WT( 6) = 0.27292508677790063071448D+00
        WT( 7) = 0.26280454451024666218069D+00
        WT( 8) = 0.23319376459199047991852D+00
        WT( 9) = 0.18629021092773425142610D+00
        WT(10) = 0.12558036946490462463469D+00
        WT(11) = 0.05566856711617366648275D+00
        RETURN
      ELSEIF ( NGP .EQ. 12 )  THEN
C      NGP = 12, PRECISION = 23
        PT( 1) = -.981560634246719250690549D+00
        PT( 2) = -.904117256370474856678466D+00
        PT( 3) = -.769002674194304687036894D+00
        PT( 4) = -.587317954286617447296702D+00
        PT( 5) = -.367831498998180193752692D+00
        PT( 6) = -.125233408511468915472441D+00
        PT( 7) = 0.125233408511468915472441D+00
        PT( 8) = 0.367831498998180193752692D+00
        PT( 9) = 0.587317954286617447296702D+00
        PT(10) = 0.769002674194304687036894D+00
        PT(11) = 0.904117256370474856678466D+00
        PT(12) = 0.981560634246719250690549D+00
        WT( 1) = 0.047175336386511827194620D+00
        WT( 2) = 0.10693932599531843096025D+00
        WT( 3) = 0.16007832854334622633465D+00
        WT( 4) = 0.20316742672306592174906D+00
        WT( 5) = 0.23349253653835480876085D+00
        WT( 6) = 0.24914704581340278500056D+00
        WT( 7) = 0.24914704581340278500056D+00
        WT( 8) = 0.23349253653835480876085D+00
        WT( 9) = 0.20316742672306592174906D+00
        WT(10) = 0.16007832854334622633465D+00
        WT(11) = 0.10693932599531843096025D+00
        WT(12) = 0.04717533638651182719462D+00
        RETURN
      ENDIF
      RETURN
      END
      SUBROUTINE  GDERIV (NSPACE, N, AJINV, DELTA, GLOBAL)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        NSPACE GLOBAL DERIVATIVES OF N INTERPOLATION
C               FUNCTIONS AT A LOCAL POINT.
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  AJINV(NSPACE,NSPACE), DELTA(NSPACE,N),
     1           GLOBAL(NSPACE,N)
C     NSPACE = DIMENSION OF SPACE
C     N      = NUMBER OF NODES PER ELEMENT
C     AJINV  = INVERSE JACOBIAN MATRIX AT LOCAL POINT
C     DELTA  = LOCAL COORD DERIV AT POINT OF INTEREST
C     GLOBAL = GLOBAL DERIVATIVES MATRIX AT LOCAL POINT
C                  GLOBAL = AJINV*DELTA
      DO 30  I = 1, NSPACE
        DO 20  J = 1, N
          SUM = 0.0
          DO 10  K = 1, NSPACE
            SUM = SUM + AJINV(I,K)*DELTA(K,J)
 10       CONTINUE
        GLOBAL(I,J) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  GENELM ( IE, M, NE, NDFREE, NITER, LPTEST, LHOMO, 
     1    NHOMO, NULCOL, N, NSPACE, NELFRE, NRB, NQP, NGEOM,
     2    NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 
     3    LNODE, INDEX, X, DDOLD, COORD, S, C, H, DGH, B, E, EB, 
     4    STRAIN, STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     5    AJ, AJINV, HINTG, D, PRTLPT, FLTNP, FLTEL, FLTMIS,
     6    ELPROP, PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, 
     7    LPPROP, NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, LT, 
     8    LSHAPE, LTUSER, NG )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C          GENERATE ELEMENT MATRICES AND POST SOLUTION DATA
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
C         SYSTEM DATA
      DIMENSION  X(M,NSPACE), DDOLD(NDFREE), LNODE(N), INDEX(NELFRE)
C         SYSTEM PROPERTIES
      DIMENSION  PRTLPT(N,0:NNPFLO), FLTNP(M,0:NNPFLO), 
     1           FLTEL(NE,0:NLPFLO), NPFIX(M,0:NNPFIX), 
     2           LPFIX(NE,0:NLPFIX)
C        FOR USE IN ELSQ, ELCOL, OR ELPOST:
      DIMENSION  COORD(N,NSPACE), S(NELFRE,NELFRE),C(NELFRE), H(N), 
     1           DGH(NSPACE,N), B(NRB,NELFRE), E(NRB,NRB), 
     2           EB(NRB,NELFRE), STRAIN(NRB+2), STRAN0(NRB), 
     3           STRESS(NRB+2), BODY(NSPACE), PT(NPARM,0:NQP), 
     4           WT(0:NQP), DLH(NSPACE,N), G(NGEOM), DLG(NPARM,NGEOM),
     5           AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), HINTG(N), 
     6           XYZ(NSPACE), D(NELFRE), FLTMIS(0:MISCFL), 
     7           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 
     8           LPROP(0:NLPFIX), LPPROP(0:NNPFIX)
C                     VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DDOLD   = SYSTEM NODAL PARAMETERS FROM LAST ITERATION
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF REAL PROPERTIES
C     FLTEL   = REAL PROPERTIES OF ELEMENTS
C     FLTMIS  = MISCELLANEOUS REAL PROPERTIES OF SYSTEM
C     FLTNP   = REAL PROPERTIES OF SYSTEM NODES
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     IE      = CURRENT ELEMENT NUMBER
C     INDEX   = SYSTEM DOF NUMBERS ASSOCIATED WITH ELEMENT
C     LHOMO   = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS
C     LNODE   = THE N ELEMENT INCIDENCES OF THE ELEMENT
C     LPFIX   = SYSTEM ARRAY OF INTEGER ELEM PROPERTIES
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER ELEMENT PROPERTIES
C     LPTEST  > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED
C     M       = NUMBER OF SYSTEM NODES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NDFREE  = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NE      = NUMBER OF ELEMENTS
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NHOMO   = 1, IF NODAL PROPERTIES ARE HOMOGENEOUS
C     NITER   = NO. OF ITERATIONS TO BE RUN (USUALLY 1)
C     NMAT    = MATERIAL TYPE NUMBER 
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NPFIX   = INTEGER PROPERTIES AT ALL NODES
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4,5 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     NULCOL  > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     WT      = QUADRATURE WEIGHTS
C     X       = COORDINATES OF SYSTEM NODES
C     XYZ     = SPACE COORDINATES AT A POINT
C
C-->   EXTRACT NODAL COORDINATES
      CALL  ELCORD (M, N, NSPACE, X, COORD, LNODE)
C      EXTRACT NODAL PARAMETERS FROM LAST ITERATION (IF ANY)
      IF ( NITER .GT. 1 )  
     1     CALL  ELFRE (NDFREE, NELFRE, D, DDOLD, INDEX)
C      EXTRACT NODAL POINT PROPERTIES (IF ANY)
      IF ( NNPFLO .GT. 0 )  
     1     CALL  LPTPRT (N, M, NNPFLO, FLTNP, PRTLPT, NNPFIX, NPFIX, 
     2                   LPPROP, LNODE, NHOMO)
C-->   EXTRACT ELEMENT PROPERTIES (IF ANY)
      IF ( LPTEST .GT. 0 )  
     1     CALL ELPRTY (IE, LHOMO, NE, NLPFIX, NLPFLO, LPFIX, FLTEL, 
     2                  LPROP, ELPROP)
C-->   EXTRACT MATERIAL PROPERTIES (IF ANY)
      IF ( NMAT .GT. 0 )  
     1     CALL MATPRT (NMAT, NLPFLO, MISCFL, FLTMIS, PRTMAT)
C-->   GENERATE ELEMENT SQUARE AND COLUMN MATRICES
      CALL  ELSQ (N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX,
     1            NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, 
     2            C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 
     3            PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 
     4            PRTLPT, FLTMIS, ELPROP, PRTMAT, MISFIX, 
     5            LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, NTAPE3, 
     6            NTAPE4, NTAPE5, LNODE, NG, IE )
      IF ( NULCOL .EQ. 0 )  
     1     CALL  ELCOL (N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, 
     2           NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 
     3           COORD, C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, 
     4           BODY, PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, 
     5           D, PRTLPT, FLTMIS, ELPROP, PRTMAT, MISFIX, 
     6           LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, NTAPE3, 
     7           NTAPE4, NTAPE5, LNODE, NG )
C-->   STORE DATA FOR POST SOLUTION CALCULATIONS (IF ANY)
      IF ( NTAPE1 .GT. 0 )  
     1     CALL   ELPOST (N, NSPACE, NELFRE, NRB, NQP, NNPFIX, 
     2            NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, H, 
     3            DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 
     4            HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     5            PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 
     6            NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG )
C      NOTE:  SYSTEM PROPERTIES UPDATE COULD BE DONE HERE
      RETURN
      END
      SUBROUTINE  GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM,
     1                   LTPARM, LTSHAP, LTUSER )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C       GET DATA BASED ON ELEMENT TYPE (SEE SUBROUTINE INLTYP)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  LTDATA(6,NLTYPE)
C     LT     = ELEMENT TYPE NUMBER
C     NLTYPE = NUMBER OF ELEMENT TYPES
C     LTN    = NUMBER OF NODES PER ELEMENT
C     LTQP   = NUMBER OF QUADRATURE POINTS
C     LGEOM  = NUMBER OF ELEMENT GEOMERTY NODES
C     LTPARM = NUMBER OF PARAMETRIC SPACES FOR ELEMENT
C     LTSHAP = ELEMNET SHAPE FLAG NUMBER
C     LTUSER = APPLICATION DEPENDENT OPTIONAL USER ITEM
      IF ( LT .LT. 1 .OR. LT .GT. NLTYPE ) STOP 
     1     'ELEMENT TYPE WRONG, GETLT' 
      LTN    = LTDATA(1,LT)
      LTQP   = LTDATA(2,LT)
      LTGEOM = LTDATA(3,LT)
      LTPARM = LTDATA(4,LT)
      LTSHAP = LTDATA(5,LT)
      LTUSER = LTDATA(6,LT)
      RETURN
      END
      SUBROUTINE  GETQD (LSHAPE, NQP, NSPACE, GPT, GWT, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C      RECOVER QUADRATURE DATA BASED ON ELEMENT SHAPE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  GPT(0:NQP), GWT(0:NQP), PT(NSPACE,0:NQP), 
     1           WT(0:NQP)
C
c      write(6,*) lshape, nqp, nspace
      NGP = NQP
      IF ( LSHAPE .LE. 1 )  THEN
C        LINE ELEMENT
        CALL GAUS1D (NGP, GPT, GWT, NGP, PT, WT)
        RETURN
      ELSEIF ( LSHAPE .EQ. 2 )  THEN
C        TRIANGULAR
c     write(6,*) 'symrul', ngp
        CALL SYMRUL (NGP, PT, WT)
c     call rprint(pt,nspace,ngp+1,0)
c     call rprint(wt,1,ngp+1,0)
        RETURN
      ELSEIF ( LSHAPE .EQ. 3 )  THEN
C        QUADRILATERAL
        NIP = SQRT ( FLOAT(NGP) ) + 0.1
c       write(6,*)'before gaus2d'
c       write(6,*)'nip,ngp,nqp', nip,ngp,nqp
        CALL  GAUS2D (NIP, GPT, GWT, NGP, PT, WT)
c       write(6,*)'nip,ngp,nqp', nip,ngp,nqp
        return
      ELSEIF  ( LSHAPE .EQ. 4 )  THEN
C        HEXAHEDRA
        NIP = ( FLOAT(NGP) )**(1./3.) + 0.1
        CALL  GAUS3D (NIP, GPT, GWT, NGP, PT, WT)
        RETURN
      ELSEIF  ( LSHAPE .EQ. 5 )  THEN
C        TETRAHEDRA
        CALL TETRUL (NGP, PT, WT)
        RETURN
      ELSEIF ( LSHAPE .EQ. 6 )  THEN
C        WEDGE
        STOP 'WEDGE NOT IN GETQD'
      ELSEIF ( LSHAPE .EQ. 7 )  THEN
C        USER SUPPLIED QUADRATURE SUBROUTINE
        CALL USERQD (NGP, GPT, GWT, NSPACE, PT, WT)
        RETURN
      ELSEIF ( LSHAPE .GT. 7 )  THEN
C        UNSUPPORTED
        STOP 'INVALID OPTION, GETQD'
      ENDIF
c       write(6,*)'nip,ngp,nqp', nip,ngp,nqp
      IF ( NQP .EQ. NGP ) RETURN
        WRITE (6,*) 'LSHAPE, NQP, NIP, NGP', LSHAPE, 
     1  NQP, NIP, NGP, ' FATAL ERROR, GETQD'
        STOP 'FATAL ERROR, GETQD'
      END
      SUBROUTINE  GUS3D (NS, N, H, AJ, AJINV, UG, Q, DL, 
     1                   UL, RST, DRST, DXYZ, USDQDS )
C     ---------------------------------------------------
C              GAUSS POINT UPWIND STREAMLINING:
C     FOR SCALAR Q COMPUTE U_S*DQ/DS UPWIND OF GAUSS PT
C                   SECOND ORDER DQ/DS       
C            Copyright J. E. Akin, 1991
C     ---------------------------------------------------
      DIMENSION  AJ(NS,NS), AJINV(NS,NS), H(N), UG(NS),
     1           UL(NS), Q(N), RST(NS), DRST(NS), 
     2           DXYZ(NS)
C    --- INPUT ARGUMENTS AT A GAUSS POINT
C    NS     = DIMENSION OF SPACE, 1 LE NS LE 3
C    N      = NUMBER OF D.O.F. ON ELEMENT
C    AJ     = SPATIAL JACOBIAN, AND ITS INVERSE AJINV
C    UG     = GLOBAL VELOCITY VECTOR
C    DL     = MAX LOCAL STEP SIZE ( MIN DIST TO EDGE / 4)
C    RST    = LOCAL COORDINATES OF GAUSS POINT
C
C    --- INPUT FROM THE NODES
C    Q      = THE TRANSPORTED QUANTITY AT EACH NODE
C    
C    --- WORKING ARRAYS
C    H    = ELEMENT INTERPOLATION FUNCTIONS
C    DRST = UPWIND INCREMENT FROM POINT RST
C    DXYZ = GLOBAL EQUIVALENT OF DRST
C    UL   = LOCAL COMPONENTS OF VELOCITY
C
C    RETURNED: USDQDS = U_S * DQ/DS
C  
C      INTERPOLATE Q AT THE GAUSS POINT
      CALL  SHAPE (RST, H, N, NS)
      CALL  MMULT (H, Q, QRST, 1, N, 1)
C      GET LOCAL VELOCITY : UL = AJINV^T * UG
      CALL  MTMULT (AJINV, UG, UL, NS, NS, 1)
C      GET GLOBAL AMD LOCAL SPEEDS
      UGS = 0.0
      ULS = 0.0
      DO  10 I = 1, NS
        UGS = UGS + UG(I)**2
 10   ULS = ULS + UL(I)**2
      UGS = SQRT ( UGS )
      ULS = SQRT ( ULS )
C      GET FARTHEST LOCAL UPWIND STEP
      DO  20 I = 1, NS
 20     DRST(I) = -UL(I)*DL/ULS
C      GET GLOBAL UPWIND STEP SIZE: DXYZ = AJ^T * DRST
      CALL MMULT ( AJ, DRST, DXYZ, NS, NS, 1)
      DS = 0.
      DO 30  I = 1, NS
 30     DS = DS + DXYZ(I)**2
      DS = SQRT ( DS )
C      ---- BUILD SECOND ORDER UPWIND GRADIENT ----
C          (LOCAL UPWIND POINT OVERWRITES DXYZ)
      DO  40 I = 1, NS
 40     DXYZ(I) = RST(I) + DRST(I)
C      INTERPOLATE Q AT FAR UPWIND POINT
      CALL SHAPE (DXYZ, H, N, NS)
      CALL MMULT (H, Q, QRST3, 1, N, 1)
C      OVERWRITE DXYZ WITH MIDDLE POINT
      DO 50  I = 1, NS
 50     DXYZ(I) = RST(I) + DRST(I)*0.5
C      INTERPOLATE Q AT MIDDLE UPWIND POINT
      CALL SHAPE (DXYZ, H, N, NS)
      CALL MMULT (H, Q, QRST2, 1, N, 1)
C      UPWIND GRADIENT OF Q
      DQDS = (3.*QRST - 4.*QRST2 + QRST3)/DS
C      PRODUCT OF SPEED AND UPWIND GRADIENT
      USDQDS = UGS*DQDS
      RETURN
      END
      SUBROUTINE  HOOKE  (E, STRAIN, STRAN0, STRESS, NRB )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C              STRESSES DUE TO INITIAL STRAINS
C     STRESS(L) = E(L,M) * ( STRAIN(M) - STRAN0(M) )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( ZERO = 0.0 )
      DIMENSION E(NRB,NRB), STRAIN(NRB), STRAN0(NRB), STRESS(NRB)
C     E      = CONSTITUTIVE MATRIX
C     NRB    = NUMBER OF ROWS IN B MATRIX
C     STRAIN = MECHANICAL STRAIN VECTOR
C     STRAN0 = INITIAL STRAIN VECTOR
C     STRESS = STRESS VECTOR
      DO 20  I = 1, NRB
        SUM = ZERO
        DO 10  K = 1, NRB
          EIK = E(I,K)
          IF ( EIK .EQ. ZERO )  GO TO 10
            DK = STRAIN(K) - STRAN0(K)
            IF ( DK .EQ. ZERO )  GO TO 10
              SUM = SUM + EIK*DK
 10     CONTINUE
        STRESS(I) = SUM
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  I2BY2 (A, AINV, DET)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CALCULATE THE DETERMINATE AND INVERSE OF A(2,2)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  A(2,2), AINV(2,2)
C     A    = ORIGINAL MATRIX
C     AINV = INVERSE OF MATRIX A
C     DET  = DETERMINANT OF A
      DET  = A(1,1)*A(2,2) - A(1,2)*A(2,1)
      IF ( DET .EQ. 0.0 )  THEN
        STOP 'SINGULAR 2X2 MATRIX'
      ELSE
        AINV(1,1) =  A(2,2)/DET
        AINV(1,2) = -A(1,2)/DET
        AINV(2,1) = -A(2,1)/DET
        AINV(2,2) =  A(1,1)/DET
        RETURN
      ENDIF
      END
      SUBROUTINE  I3BY3 (A, AINV, DET)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND INVERSE AND DETERMINATE OF MATRIX A(3,3)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(3,3), AINV(3,3)
C     A    = ORIGINAL MATRIX
C     AINV = INVERSE OF MATRIX A
C     DET  = DETERMINANT OF A
      AINV(1,1) =  A(2,2)*A(3,3) - A(3,2)*A(2,3)
      AINV(2,1) = -A(2,1)*A(3,3) + A(3,1)*A(2,3)
      AINV(3,1) =  A(2,1)*A(3,2) - A(3,1)*A(2,2)
      AINV(1,2) = -A(1,2)*A(3,3) + A(3,2)*A(1,3)
      AINV(2,2) =  A(1,1)*A(3,3) - A(3,1)*A(1,3)
      AINV(3,2) = -A(1,1)*A(3,2) + A(3,1)*A(1,2)
      AINV(1,3) =  A(1,2)*A(2,3) - A(2,2)*A(1,3)
      AINV(2,3) = -A(1,1)*A(2,3) + A(2,1)*A(1,3)
      AINV(3,3) =  A(1,1)*A(2,2) - A(2,1)*A(1,2)
      DET = A(1,1)*AINV(1,1) + A(1,2)*AINV(2,1)
     1    + A(1,3)*AINV(3,1)
      IF ( DET .EQ. 0.0 )  THEN
        STOP 'SINGULAR 3X3 MATRIX'
      ELSE
        DO 20  J = 1,3
          DO 10  I = 1,3
   10     AINV(I,J) = AINV(I,J)/DET
   20   CONTINUE
        RETURN
      ENDIF
      END
      SUBROUTINE  ICOMB (LIST, LONG)
C     ------------------------------------------
C     COMB SORT OF INTEGER LIST, SEE BYTE APR 91
C     ------------------------------------------
      DIMENSION  LIST(LONG)
      IGAP = LONG*10
  10  IGAP = MAX0 ( IGAP/13, 1 )
      ISWAP = 0
      DO 20  I = 1, (LONG-IGAP)
        J = I + IGAP
        IF ( LIST(I) .GT. LIST(J) )  THEN
C         SWAP THE ELEMENTS
          IHOLD   = LIST(I)
          LIST(I) = LIST(J)
          LIST(J) = IHOLD
          ISWAP   = ISWAP + 1
        ENDIF
  20  CONTINUE
      IF ( ISWAP .EQ. 0 .AND. IGAP .EQ. 1 )  THEN
        RETURN
      ELSE
        GO TO 10
      ENDIF
      END
      SUBROUTINE  IN3T (XY, COORD, INSIDE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C      IS POINT XY INSIDE A TRIANGLE WITH GIVEN COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  XY(2), COORD(3,2)
C     COORD  = PHYSICAL COORDINATES OF NODES
C     INSIDE = 0 IF XY IS NOT IN ELEMENT, ELSE = 1
C     XY     = PHSYICAL COORDINATES OF POINT INSIDE ELEMENT
C     
C     NODES ARE ASSUMED TO BE NUMBERED COUNTERCLOCKWISE
C      INITALIZE AS OUTSIDE (SEE INSIDE.F AS ALTERNATE) 
      INSIDE = 0
C      LOOP OVER 3 SIDES TESTING TRIANGULAR AREA (+ IF IN)
      TWOA = COORD(1,1)*(COORD(2,2) - XY(2)) 
     1     + COORD(2,1)*(XY(2) - COORD(1,2)) 
     2     + XY(1)*(COORD(1,2) - COORD(2,2))
      IF ( TWOA .LT. 0.0 )  RETURN
        TWOA = COORD(2,1)*(COORD(3,2) - XY(2)) 
     1       + COORD(3,1)*(XY(2) - COORD(2,2)) 
     2       + XY(1)*(COORD(2,2) - COORD(3,2))
        IF ( TWOA .LT. 0.0 )  RETURN
          TWOA = COORD(3,1)*(COORD(1,2) - XY(2)) 
     1         + COORD(1,1)*(XY(2) - COORD(3,2)) 
     2         + XY(1)*(COORD(3,2) - COORD(1,2))
          IF ( TWOA .LT. 0.0 )  RETURN
C              POINT IS INSIDE
              INSIDE = 1
              RETURN
              END
      SUBROUTINE  IN4Q (XY, COORD, INSIDE, R, S)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND LOCAL (R,S) COORDINATES OF POINT XY IN A Q4 ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     REF: C. HUA, FE IN ANAL & DESIGN, 7, 159-166, 1990
      DOUBLE PRECISION  A, B, C, ROOT, FOUR, HALF, R1, R2
      PARAMETER  ( ZERO = 0.D0, HALF = 0.5D0, ONE = 1.D0, 
     1             FOUR = 4.D0, TOL = 1.D-7 )
      DIMENSION  XY(2), COORD(4,2), TOABC(3,4), ABC(3,2)
C     COORD  = PHYSICAL COORDINATES OF NODES
C     INSIDE = 0 IF XY IS NOT IN ELEMENT, ELSE = 1
C     R,S    = NATURAL COORDINATES OF THE PT (-1 TO +1)
C     XY     = PHSYICAL COORDINATES OF POINT INSIDE ELEMENT
C     
C     NODES ARE ASSUMED TO BE NUMBERED COUNTERCLOCKWISE
      DATA TOABC / 1., -1., -1.,  -1.,  1., -1.,
     1             1.,  1.,  1.,  -1., -1.,  1. /
      EQUIVALENCE (ABC(1,1),A1), (ABC(2,1),B1), (ABC(3,1),C1),
     1            (ABC(1,2),A2), (ABC(2,2),B2), (ABC(3,2),C2)
C      INITALIZE AS OUTSIDE (SEE INSIDE.F AS ALTERNATE) 
      INSIDE = 0
      R      = 99.
      S      = 99.
C      LOOP OVER 4 SIDES TESTING TRIANGULAR AREA (+ IF IN)
      TWOA = COORD(1,1)*(COORD(2,2) - XY(2)) 
     1     + COORD(2,1)*(XY(2) - COORD(1,2)) 
     2     + XY(1)*(COORD(1,2) - COORD(2,2))
      IF ( TWOA .LT. -TOL )  RETURN
        TWOA = COORD(2,1)*(COORD(3,2) - XY(2)) 
     1       + COORD(3,1)*(XY(2) - COORD(2,2)) 
     2       + XY(1)*(COORD(2,2) - COORD(3,2))
        IF ( TWOA .LT. -TOL )  RETURN
          TWOA = COORD(3,1)*(COORD(4,2) - XY(2)) 
     1         + COORD(4,1)*(XY(2) - COORD(3,2)) 
     2         + XY(1)*(COORD(3,2) - COORD(4,2))
          IF ( TWOA .LT. -TOL )  RETURN
            TWOA = COORD(4,1)*(COORD(1,2) - XY(2)) 
     1           + COORD(1,1)*(XY(2) - COORD(4,2)) 
     2           + XY(1)*(COORD(4,2) - COORD(1,2))
            IF ( TWOA .LT. -TOL )  RETURN
C              POINT IS INSIDE, GET LOCAL COORDINATES
              INSIDE = 1
              D1     = 4.*XY(1) - COORD(1,1) - COORD(2,1) 
     1               - COORD(3,1) - COORD(4,1)
              D2     = 4.*XY(2) - COORD(1,2) - COORD(2,2) 
     1               - COORD(3,2) - COORD(4,2)
              CALL  MMULT (TOABC,COORD,ABC,3,4,2)
              AB = A1*B2 - A2*B1
              AC = A1*C2 - A2*C1
              AD = A1*D2 - A2*D1
              DC = D1*C2 - D2*C1
C              CHECK CASES
              IF ( (A1*A2*AB*AC) .NE. ZERO                   .OR.
     1             (A1 .EQ. ZERO .AND. (A2*C1) .NE. ZERO )   .OR.
     2             (A2 .EQ. ZERO .AND. (A1*B2) .NE. ZERO ) ) THEN
                A    = AB
                B    = C1*B2 - C2*B1 - AD
                C    = DC
                ROOT = DSQRT( B*B - FOUR*A*C )
                R1   = HALF*(-B + ROOT)/A
                R2   = HALF*(-B - ROOT)/A
                IF ( -ONE .LE. R1 .AND. ONE .GE. R1 ) THEN
                  R = R1
                ELSE
                  R = R2
                ENDIF
                S = (AD - AB*R)/AC
              ELSEIF (((A1*A2) .NE. ZERO) .AND. (AB .EQ. ZERO) ) THEN
                R = A1*DC/(B1*AC + A1*AD)
                S = AD/AC 
              ELSEIF (((A1*A2) .NE. ZERO) .AND. (AC .EQ. ZERO) ) THEN
                DB = D1*B2 - D2*B1
                R  = AD/AB
                S  = A1*DB/(C1*AB + A1*AD)
              ELSE
                BC = B1*C2 - B2*C1
                BD = B1*D2 - B2*D1
                R  = DC/(A1*D2 + BC)
                S  = BD/(A2*D1 + BC)
              ENDIF
              ERRORX = ABS( B1*R + C1*S - D1 + A1*R*S )
              ERRORY = ABS( B2*R + C2*S - D2 + A2*R*S )
              IF ( ERRORX .GT. TOL .OR. ERRORY .GT. TOL ) WRITE(6,*)
     1          'WARNING: IN4Q ERRORS ARE ', ERRORX, ERRORY
              IF ( -ONE .GT. R .OR. ONE .LT. R ) STOP 'IN4Q ERROR'
              IF ( -ONE .GT. S .OR. ONE .LT. S ) STOP 'IN4Q ERROR'
              RETURN
              END
      SUBROUTINE  INCEQ (NG, MAXACT, NUMCE, NREQ, CEQ, 
     1                   NDXC, M)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        READ NODAL PARAMETER CONSTRAINT EQUATION DATA
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NCRD=5, NPRT=6, NBUG=6 )
      DIMENSION  CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE),
     1           NREQ(MAXACT)
C     CEQ(I,J)  = CONSTRAINT COEFF I OF EQUATION J
C     MAXACT    = NUMBER OF ACTIVE ESSENTIAL BC'S AND
C                 CONSTRAINTS, >= 1
C     NG        = NO. PARAMETERS PER NODE
C     NDXC(I,J) = CONSTRAINT DOF NO I OF EQUATION J
C     NREQ(I)   = NUMBER OF CONSTRAINTS OF TYPE I
      WRITE (NPRT,*) ' '
      WRITE (NPRT,*) '*** CONSTRAINT EQUATION DATA ***'
C      WARN IF NO CONSTRAINTS
      IF ( MAXACT .LT. 1 )  THEN
        WRITE (NPRT,*) 'WARNING, NO CONSTRAINTS  !!!!!!!'
        RETURN
      ENDIF
      IEQ = 0
      DO 130  IN = 1, MAXACT
        NTEST = NREQ(IN)
        IF ( NTEST .EQ. 0 )  GO TO 130
          GO TO (10,30,50,70), IN
C-->         TYPE 1     D(L1) = A1
 10         WRITE (NPRT,5010)
 5010       FORMAT ('CONSTRAINT TYPE ONE',/,
     1              'EQ. NO.   NODE1   PAR1          A1')
            DO 20  NEQ = 1, NTEST
              IEQ = IEQ + 1
              READ (NCRD,5020)  NODE1, IPAR1, A1
 5020         FORMAT ( 2I10, F10.0 )
              WRITE (NPRT,5030)  IEQ, NODE1, IPAR1, A1
 5030         FORMAT ( 3I7 ,2X, 1PE12.5 )
              IF ( NODE1 .GT. M .OR. IPAR1 .GT. NG )  
     1          STOP 'DATA ERROR IN SUBROUTINE INCEQ'
              NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1
 20         CEQ(1,IEQ) = A1
          GO TO 130
C-->         TYPE 2   A1*D(L1)+A2*D(L2)=A3
 30         WRITE (NPRT,5050)
 5050       FORMAT ('CONSTRAINT TYPE TWO',/,
     1      'EQ. NO.   NODE1   PAR1   NODE2   PAR2',
     2      '          A1          A2            A3')
            DO 40  NEQ = 1, NTEST
              IEQ = IEQ + 1
              READ (NCRD,5060) NODE1, IPAR1, NODE2, IPAR2, 
     1                         A1, A2, A3
 5060         FORMAT ( 4I10, 3F10.0 )
              WRITE (NPRT, 5070)  IEQ, NODE1, IPAR1, NODE2, 
     1                            IPAR2, A1, A2, A3
 5070         FORMAT (5I7, 3(2X, 1PE12.5))
              IF ( NODE1 .GT. M  .OR. NODE2 .GT. M .OR. 
     1             IPAR1 .GT. NG .OR. IPAR2 .GT. NG )  
     2             STOP 'DATA ERROR IN SUBROUTINE INCEQ'
              NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1
              NDXC(2,IEQ) = NG*(NODE2 - 1) + IPAR2
              CEQ(1,IEQ) = A2/A1
 40         CEQ(2,IEQ) = A3/A1
          GO TO 130
C            TYPE 3   A1*D(L1)+A2*D(L2)+A3*D(L3)=A4
 50         WRITE (NPRT,5080)
 5080       FORMAT ('CONSTRAINT TYPE THREE',/,
     1      'EQ. NO.   NODE1   PAR1   NODE2   PAR2   NODE3',
     2      '   PAR3          A1          A2          A3',
     3      '          A4')
            DO 60  NEQ = 1, NTEST
              IEQ = IEQ + 1
              READ (NCRD, 5090) NODE1, IPAR1, NODE2, IPAR2, 
     1                          NODE3, IPAR3, A1, A2, A3, A4
 5090         FORMAT ( 6I10, /, 4F10.0 )
              WRITE (NPRT, 5100)  IEQ, NODE1, IPAR1, NODE2, 
     1                            IPAR2, NODE3, IPAR3, A1, A2, 
     2                            A3, A4
 5100         FORMAT ( 7I7, 4(2X,1PE12.5))
              IF ( NODE1 .GT. M  .OR. NODE2 .GT. M .OR. 
     1             NODE3 .GT. M  .OR.  IPAR3 .GT. NG .OR.
     2             IPAR1 .GT. NG .OR. IPAR2 .GT. NG )  
     3             STOP 'DATA ERROR IN SUBROUTINE INCEQ'
              NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1
              NDXC(2,IEQ) = NG*(NODE2 - 1) + IPAR2
              NDXC(3,IEQ) = NG*(NODE3 - 1) + IPAR3
              CEQ(1,IEQ) = A2/A1
              CEQ(2,IEQ) = A3/A1
 60         CEQ(3,IEQ) = A4/A1
          GO TO 130
C            OTHER TYPES NOT TREATED
 70         STOP 'UNSUPPORTED OPTION, INCEQ'
 130  CONTINUE
      RETURN
      END
      SUBROUTINE  INDXEL (N, LEMFRE, NG, LNODE, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     DETERMINE DEGREES OF FREEDOM NUMBERS OF ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  INDEX(LEMFRE), LNODE(N)
C     N      = NUMBER OF NODES PER ELEMENT
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     LEMFRE = N*NG = NUMBER OF DOF PER ELEMENT
C     LNODE  = NODAL INCIDENCES OF THE ELEMENT
C     INDEX  = SYSTEM DOF NOS OF ELEMENT DOF
C      LOOP OVER NODES OF ELEMENT
      DO 20  K = 1, N
        IDOF = -NG
        IF ( LNODE(K) .GT. 0 ) IDOF = IDOF + NG*LNODE(K)
        NGKM1 = NG*(K-1)
C        LOOP OVER GENERALIZED DEGREES OF FREEDOM
        DO 10  IG = 1, NG
          IELM = NGKM1 + IG
C         INDEX(NG*(K-1)+IG) = NG*(LNODE(K)-1) + IG
 10     INDEX(IELM) = IDOF + IG
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  INDXPT (IPT, NG, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     DETERMINE DEGREES OF FREEDOM NUMBERS AT A NODE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  INDEX(NG)
C     IPT   = SYSTEM NODE NUMBER
C     NG    = NUMBER OF PARAMETERS (DOF) PER NODE
C     INDEX = SYSTEM DOF NOS OF NODAL DOF
      NGIM1 = NG*(IPT - 1)
      DO 10  J = 1, NG
C       INDEX(J) = NG*(IPT - 1) + J
        INDEX(J) = NGIM1 + J
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  INFLUX (NSEG, LBN, LNODE, FLUX, NG, COORD, 
     1                    NSPACE, X, M, INDEX, C, CC, NDFREE, 
     2                    S, SS, NCOEFF, NFLUX, MODE, N, IOPT,
     3                    NQP, NPARM, H, DGH, PT, WT, XYZ, DLH, 
     4                    G, DLG, AJ, AJINV, LHOMO, NBSFIX, 
     5                    NBSFLO, NBSPFX, FLTBS, GPT, GWT, NGF )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        READ FLUX BOUNDARY COND. AND APPLY TO SYSTEM EQS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NCRD = 5, NPRT = 6 )
      DIMENSION  X(M,NSPACE),    COORD(LBN,NSPACE),
     1           FLUX(LBN,NGF),  CC(NDFREE), C(NFLUX),
     2           S(NFLUX,NFLUX), SS(NCOEFF),
     3           LNODE(LBN),     INDEX(NFLUX)
C
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION   H(N), DGH(NSPACE,N), PT(NPARM,0:NQP), 
     1            WT(0:NQP), XYZ(NSPACE), DLH(NSPACE,N), G(LBN), 
     2            DLG(NPARM,LBN), AJ(NSPACE,NSPACE), 
     3            AJINV(NSPACE,NSPACE), GPT(0:NQP), GWT(0:NQP)
C
C        OPTIONAL SEGMENT PROPERTIES
      DIMENSION   FLTBS(0:NSEG,0:NBSFLO), NBSPFX(0:NSEG,0:NBSFIX)
C
C     C      = BOUNDARY SEGMENT COLUMN MATRIX
C     CC     = COLUMN MATRIX OF SYSTEM EQUATIONS
C     COORD  = SPATIAL COORDINATES OF SEGMENT NODES
C     FLUX   = SPECIFIED COMPONENTS OF FLUX AT NODES
C     FLTBS  = REAL PROPERTIES ON THE SEGMENTS
C     INDEX  = SYSTEM DEGREE OF FREEDOM NUMBERS ARRAY
C     IOPT   = PROBLEM MATRIX REQUIREMENT FLAG (RETURNED)
C            = 1, BFLUX CALCULATES C ONLY
C            = 2, BFLUX CALCULATES S ONLY
C            = 3, BFLUX GIVES BOTH C AND S
C     LBN    = NO. OF NODES ON AN ELEMENT BOUNDARY SEGMENT
C     LNODE  = INCIDENCES OF SEGEMENT ISEG
C     M      = NO. OF SYSTEM NODES,
C     MAXBAN = SYSTEM BANDWIDTH = NCOEFF/NDFREE
C     MODE   = STORAGE TYPE, 0-SKYLINE 1-BANDED
C     NBSFIX  = NUMBER OF INTEGER PROPERTIES PER SEGMENT
C     NBSFLO  = NUMBER OF REAL PROPERTIES PER SEGMENT
C     NBSPFX  = INTEGER PROPERTIES ON THE SEGMENTS
C     NCOEFF = NUMBER OF TERMS IN SS
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NG     = NO. OF DOF PER NODE
C     NGF    = NO. OF FLUX COMPONENTS PER NODE
C     NQP    = NUMBER OF *ELEMENT* QUADRATURE POINTS, >= NSQP
C     NSEG   = NO. OF ELEMENT BOUNDARY SEGMENTS IN SYSTEM
C     NSPACE = DIMENSION OF SPACE
C     NSQP   = NUMBER OF *SEGMENT* QUADRATURE POINTS,<= NQP
C     NFLUX  = LBN*NG = NUMBER OF SEGMENT DOF
C     S      = BOUNDARY SEGMENT SQ MATRIX
C     SS     = SYSTEM SQUARE MATRIX UPPER BAND
C     XYZ    = COORDINATES OF SYSTEM NODES
      IOPT = 0
      WRITE (NPRT,5000) LBN, NGF
 5000 FORMAT ( /, '*** ELEMENT BOUNDARY FLUXES ***',/,
     2'SEGMENT    ',I3,' NODES ON THE SEGMENT', /,
     3'SEGMENT    ',I3,' FLUX COMPONENTS PER NODE')
      DO 30  ISEG = 1, NSEG
C-->     READ BOUNDARY NODES
        READ (NCRD,5010)  LNODE
 5010   FORMAT ( (16I5) )
C-->     READ BOUNDARY FLUX
        READ (NCRD,5020) ( (FLUX(K,IS),IS=1,NG), K=1,LBN )
 5020   FORMAT ( (8F10.4) )
        WRITE (NPRT,5030)  ISEG, LNODE
 5030   FORMAT ( I4, (16I5) )
        DO 5  L = 1, LBN
          IF ( LNODE(L) .LT. 1 .OR. LNODE(L) .GT. M ) 
     1         STOP 'INVALID NODE NUMBER IN INFLUX'
 5       WRITE (NPRT,5040)  ISEG, (FLUX(L,IS), IS=1,NG)
 5040    FORMAT ( I4, (6(1PE11.3)) )
C        EXTRACT COORDINATES
        CALL  ELCORD (M,LBN,NSPACE,X,COORD,LNODE)
C-->     CALCULATE BOUNDARY FLUX MATRICES (PROB DEPENDENT)
        NSQP   = NQP
        NSPARM = NPARM
        CALL  BFLUX (FLUX, COORD, LBN, N, NSPACE, NFLUX, 
     1               NG, C, S, IOPT, NSQP, NSPARM, H, DGH, 
     2               PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, 
     3               LHOMO, ISEG, NSEG, NBSFIX, NBSFLO, 
     4               NBSPFX, FLTBS, GPT, GWT, NGF )
        IF ( IOPT .EQ. 0 )  THEN
          STOP 'FLUX NOT USED, SET IOPT > 0 IN BFLUX'
        ENDIF
        IF ( NSQP .GT. NQP ) STOP 'NQP INCREASED IN BFLUX'
C        INSERT BOUNDARY FLUX MATRICES INTO SYSTEM EQ
        CALL  INDXEL (LBN,NFLUX,NG,LNODE,INDEX)
        IF ( IOPT .EQ. 1 .OR. IOPT .EQ. 3 )
     1       CALL STORCL (NDFREE,NFLUX,INDEX,C,CC)
        IF ( IOPT .EQ. 2 .OR. IOPT .EQ. 3 )  THEN
          IF ( MODE .EQ. 1 )  THEN
C            BANDED MODE
            MAXBAN = NCOEFF/NDFREE
            CALL STORSQ (NDFREE,MAXBAN,NFLUX,INDEX,S,SS)
          ELSE
C            SKYLINE MODE
            STOP 'add skystore influx'
          ENDIF
        ENDIF
 30   CONTINUE
C      CLEAR ARRAY C AND S FOR LATER USE
      CALL ZEROA (NFLUX,C)
      CALL ZEROA (NFLUX*NFLUX,S)
      RETURN
      END
      SUBROUTINE  INLTYP  (NLTYPE, LTDATA, N, NQP, NGEOM, 
     1                     NPARM, LSHAPE )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C                SET OR READ ELEMENT TYPE DATA ITEMS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( NCRD =5, NPRT = 6 )
      DIMENSION  LTDATA(6,NLTYPE)
C     NLTYPE = NUMBER OF ELEMENT TYPES
C     LTN    = NUMBER OF NODES PER ELEMENT
C     LTQP   = NUMBER OF QUADRATURE POINTS
C     LGEOM  = NUMBER OF ELEMENT GEOMERTY NODES
C     LTPARM = NUMBER OF PARAMETRIC SPACES FOR ELEMENT
C     LTSHAP = ELEMNET SHAPE FLAG NUMBER
C     LTUSER = APPLICATION DEPENDENT OPTIONAL USER ITEM
      IF ( NLTYPE .EQ. 1 )  THEN
C        DEFAULT IS SINGLE TYPE ONLY
        LTDATA(1,1) = N
        LTDATA(2,1) = NQP
        LTDATA(3,1) = NGEOM
        LTDATA(4,1) = NPARM
        LTDATA(5,1) = LSHAPE
        LTDATA(6,1) = 0
        LT     = 1
        LTUSER = 0
          WRITE (NPRT,5020) LT, N, NQP, NGEOM, NPARM, 
     1                      LSHAPE, LTUSER
      ELSE
C        READ SEVERAL DIFFERENT TYPES
        DO  10 IT = 1, NLTYPE
          READ (NCRD,5000) LT, LTN, LTQP, LTGEOM, LTPARM, 
     1                     LTSHAP, LTUSER
 5000     FORMAT ( 7I5 )
          IF ( LT .LT. 1 .OR. LT .GT. NLTYPE ) STOP 
     1        'ELEMENT TYPE WRONG, INLTYP' 
          IF ( LTN .GT. N .OR. LTQP .GT. NQP .OR. 
     1         LTGEOM .GT. NGEOM .OR. LTPARM .GT. NPARM )  
     2         STOP 'ELEMENT TYPE DATA EXCEEDS MAXIMUM, INLTYP'
          LTDATA(1,LT) = LTN
          LTDATA(2,LT) = LTQP
          LTDATA(3,LT) = LTGEOM
          LTDATA(4,LT) = LTPARM
          LTDATA(5,LT) = LTSHAP
          LTDATA(6,LT) = LTUSER
          WRITE (NPRT,5020) LT, LTN, LTQP, LTGEOM, LTPARM, 
     1                      LTSHAP, LTUSER
 5020     FORMAT ( /, 'ELEMENT TYPE NUMBER =', I3, /,
     1    'NUMBER OF NODES PER ELEMENT ..........', I3, /, 
     2    'NUMBER OF QUADRATURE POINTS ..........', I3, /, 
     3    'NUMBER OF GEOMETRIC CONTROL NODES ....', I3, /, 
     4    'NUMBER OF PARAMETRIC DIMENSIONS ......', I3, /,
     5    'ELEMENT SHAPE NUMBER . ...............', I3, /,
     6    'APPLICATION DEPENDENT USER FLAG ......', I3)
 10     CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE  INPROP (M, NE, NNPFIX, NNPFLO, NLPFIX, 
     1                   NLPFLO, MISCFX, MISCFL, FLTNP, 
     2                   FLTEL, FLTMIS, NPFIX, LPFIX, 
     3                   MISFIX, NHOMO, LHOMO, NBSFIX,
     4                   NBSFLO, NBSPFX, FLTBS, NBS)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      INPUT NODAL POINT, ELEMENT, AND MISCELLANEOUS
C                  SYSTEM PROPERTIES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER  ( NCRD = 5, NPRT = 6 )
      DIMENSION  FLTNP(M,0:NNPFLO),  FLTEL(NE,0:NLPFLO),
     1           FLTMIS(0:MISCFL),   FLTBS(0:NBS,0:NBSFLO),
     2           MISFIX(0:MISCFX),   NPFIX(M,0:NNPFIX), 
     3           LPFIX(NE,0:NLPFIX), NBSPFX(0:NBS,0:NBSFIX) 
C     M      = NUMBER OF SYSTEM NODES
C     NBS    = NUMBER OF BOUNDARY SEGMENTS WITH FLUX
C     NE     = NUMBER OF ELEMENTS IN SYSTEM
C     FLTNP, FLTEL, FLTMIS, FLTBS = REAL PROPERTIES OF 
c              SYSTEM NODES, ELEMENTS, SEGMENTS, AND MISC.
C     NPFIX, LPFIX, MISFIX, NBSFIX = INTEGER PROPERTIES OF 
C              SYSTEM NODES, ELEMENTS, SEGMENTS, AND MISC.
C     LHOMO  = 1, IF ALL ELEMENTS & SEGMENTS SAME AS FIRST
C     NHOMO  = 1, IF ALL NODES SAME AS FIRST ONE
C     NBSFLO = NUMBER OF REAL SEGMENT PROPERTIES
C     NNPFLO = NUMBER OF REAL NODAL PROPERTIES
C     NBSFIX = NUMBER OF INTEGER SEGMENT PROPERTIES
C     NNPFIX = NUMBER OF INTEGER NODAL PROPERTIES
C     NLPFIX = NUMBER OF INTEGER ELEMENT PROPERTIES
C     MISCFL = NUMBER OF MISC. REAL SYSTEM PROPERTIES
C     MISCFX = NUMBER OF MISC. INTEGER SYSTEM PROPERTIES
      IF ( NNPFIX .GT. 0 .OR. NNPFLO .GT. 0 )  THEN
C-->     READ NODAL POINT PROPERTIES
        WRITE (NPRT,5000)
 5000   FORMAT ( /, '***   NODAL  POINT  PROPERTIES   ***',/,
     1          '     NODE    PROPERTY     VALUE')
        MAX = M
        IF ( NHOMO .EQ. 1 )  MAX = 1
        IF ( NNPFIX .GT. 0 )  THEN    
          DO 10  I = 1, MAX
            READ (NCRD,5010) J, (NPFIX(J,K), K=1,NNPFIX)
 5010       FORMAT ( I10, (7I10) )
            IF ( J .GE. M )  GO TO 20
 10       CONTINUE
C          ECHO INPUT
 20       WRITE (NPRT,5030) ( (J, K, NPFIX(J,K), J = 1, MAX),
     1                         K = 1, NNPFIX )
 5030     FORMAT (I10, I10, 3X, I10)
          WRITE (NPRT,*) 'END INTEGER PROPERTIES OF NODES'
          WRITE (NPRT,*) ' '
        ENDIF
        IF ( NNPFLO .GT. 0 )  THEN
          DO 40  I = 1, MAX
            READ (NCRD,5050) J, (FLTNP(J,K), K = 1,NNPFLO)
 5050       FORMAT ( I10, 7F10.4, (/, 8F10.4) )
c5050       FORMAT ( I10, (7F10.4) )
            IF ( J .GE. M )  GO TO 50
 40       CONTINUE
C          ECHO INPUT
 50       WRITE (NPRT,5060) ( (J, K, FLTNP(J,K), J = 1, MAX),
     1                         K = 1, NNPFLO )
 5060     FORMAT (I10, I10, 3X, 1PE12.5)
          WRITE (NPRT,*) 'END OF REAL PROPERTIES OF NODES'
          WRITE (NPRT,*) ' '
        ENDIF
      ENDIF
      IF ( NLPFIX .GT. 0 .OR. NLPFLO .GT. 0 )  THEN
C-->     READ ELEMENT PROPERTIES
        WRITE (NPRT,5080)
 5080   FORMAT ( /, '***  ELEMENT  PROPERTIES   ***',/,
     1         'ELEMENT  PROPERTY      VALUE')
        MAX = NE
        IF ( LHOMO .EQ. 1 )  MAX = 1
        IF ( NLPFIX .GT. 0 )  THEN
          DO 70  I = 1, MAX
            READ (NCRD,5010)  J, (LPFIX(J,K), K=1,NLPFIX)
            IF ( J .GE. NE )  GO TO 80
 70       CONTINUE
C          ECHO
 80       WRITE (NPRT,5030) ( (J, K, LPFIX(J,K), J = 1,MAX),
     1                         K = 1, NLPFIX )
          WRITE (NPRT,*) 'END INTEGER PROPERTIES OF ELEMENTS'
          WRITE (NPRT,*) ' '
        ENDIF
        IF ( NLPFLO .GT. 0 )  THEN
          DO 100  I = 1, MAX
            READ (NCRD,5050)  J, (FLTEL(J,K), K=1,NLPFLO)
            IF ( J .GE. NE )  GO TO 110
 100      CONTINUE
 110      WRITE (NPRT,5060) ( (J, K, FLTEL(J,K), J=1,MAX),
     1                         K = 1,NLPFLO )
          WRITE (NPRT,*) 'END REAL PROPERTIES OF ELEMENTS'
          WRITE (NPRT,*) ' '
        ENDIF
      ENDIF
      IF ( NBSFIX .GT. 0 .OR. NBSFLO .GT. 0 )  THEN
C-->     READ SEGMENT PROPERTIES
        WRITE (NPRT,5085)
 5085   FORMAT ( /, '***  SEGMENT  PROPERTIES   ***',/,
     1         'SEGMENT  PROPERTY      VALUE')
        MAX = NBS
        IF ( LHOMO .EQ. 1 )  MAX = 1
        IF ( NBSFIX .GT. 0 )  THEN
          DO 75  I = 1, MAX
            READ (NCRD,5010)  J, (NBSPFX(J,K), K=1,NBSFIX)
            IF ( J .GE. NBS )  GO TO 85
 75       CONTINUE
C          ECHO
 85       WRITE (NPRT,5030) ( (J, K, NBSPFX(J,K), J = 1,MAX),
     1                         K = 1, NBSFIX )
          WRITE (NPRT,*) 'END INTEGER PROPERTIES OF SEGMENTS'
          WRITE (NPRT,*) ' '
        ENDIF
        IF ( NBSFLO .GT. 0 )  THEN
          DO 105  I = 1, MAX
            READ (NCRD,5050)  J, (FLTBS(J,K), K=1,NBSFLO)
            IF ( J .GE. NBS )  GO TO 115
 105      CONTINUE
 115      WRITE (NPRT,5060) ( (J, K, FLTBS(J,K), J=1,MAX),
     1                         K = 1,NBSFLO )
          WRITE (NPRT,*) 'END REAL PROPERTIES OF SEGMENTS'
          WRITE (NPRT,*) ' '
        ENDIF
      ENDIF
      IF ( MISCFX .GT. 0 .OR. MISCFL .GT. 0 )  THEN
C-->     READ MISC. SYSTEM PROPERTIES
        WRITE (NPRT,5120)
 5120   FORMAT ( /, '***  MISCELLANEOUS SYSTEM PROPERTIES',
     1   '  ***',/, 'PROPERTY     VALUE')
        IF ( MISCFX .GT. 0 )  THEN
          READ (NCRD,5130)  (MISFIX(K), K=1,MISCFX)
 5130     FORMAT ( (8I10) )
C          ECHO
          DO 130  K = 1,MISCFX
            WRITE (NPRT,5140) K, MISFIX(K)
 5140       FORMAT ( I8, 3X, I10 )
 130      CONTINUE
          WRITE (NPRT,*) 'END OF INTEGER PROPERTIES OF SYSTEM'
        ENDIF
        IF ( MISCFL .GT. 0 )  THEN
          READ (NCRD,5160)  (FLTMIS(K), K=1,MISCFL)
 5160     FORMAT ( (8F10.4) )
          DO 140  K=1,MISCFL
            WRITE (NPRT,5170) K,FLTMIS(K)
 5170       FORMAT ( I8, 3X, 1PE13.5 )
 140      CONTINUE
        ENDIF
        WRITE (NPRT,*) 'END REAL PROPERTIES OF SYSTEM'
      ENDIF
c        call at(59)
      RETURN
      END
      SUBROUTINE  INPUT (M, N, NE, NG, NSPACE, X, IBC, NODES)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C              READ BASIC PROBLEM DATA
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NCRD = 5, NPRT = 6 , NBUG = 6 )
      DIMENSION  X(M,NSPACE), IBC(M), NODES(NE,N)
C     M      = NUMBER OF NODES IN SYSTEM
C     N      = NUMBER OF NODES PER ELEMENT
C     NE     = NUMBER OF ELEMENTS IN SYSTEM
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     NSPACE = DIMENSION OF SOLUTION SPACE
C     X      = SYSTEM COORDINATES OF ALL NODES
C     IBC    = PACKED NODAL CONSTRAINT INDICATOR
C     NODES  = SYSTEM ARRAY OF ELEMENT INCIDENCES
C-->   READ NODAL POINT DATA
      WRITE (NPRT,5000)  NSPACE
 5000 FORMAT ( /, '*** NODAL POINT DATA ***',/,
     1 'NODE, CONSTRAINT FLAG,',I2,' COORDINATES')
      DO 10  I = 1, M
        READ  (NCRD,5010) J, IBC(J), (X(J,K), K=1,NSPACE)
        WRITE (NPRT,5010) J, IBC(J), (X(J,K), K=1,NSPACE)
 5010   FORMAT ( 2I10, (6F10.4) )
        IF ( J .GT. M ) WRITE (NBUG,*) 'INVALID NODE, INPUT'
 10   CONTINUE
C-->   READ ELEMENT DATA
      WRITE (NPRT,5030)  N
 5030 FORMAT ( /, '*** ELEMENT CONNECTIVITY DATA ***',/,
     1        'ELEMENT NO., ', I2 ,' NODAL INCIDENCES.')
      DO 20 I = 1, NE
        READ  (NCRD,5050) J, (NODES(J,K), K=1,N)
        WRITE (NPRT,5050) J, (NODES(J,K), K=1,N)
 5050   FORMAT ( I5, (15I5) )
        IF ( J .GT. NE )  WRITE (NBUG,*) 'INVALID ELEMENT, INPUT'
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  INVDET (AJ, AJINV, DET, NSPACE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND INVERSE AND DETERMINATE OF JACOBIAN
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE)
C     NSPACE = NUMBER OF SPATIAL DIMENSIONS
C     AJ     = JACOBIAN MATRIX AT A POINT
C     AJINV  = INVERSE OF AJ
C     DET    = DETERMINATE OF AJ
C-->  1-D
      IF  ( NSPACE .EQ. 1 )  THEN
        DET = AJ(1,1)
        IF ( DET .NE. 0.0 )  THEN
          AJINV(1,1) = 1.0/DET
        ELSE
          STOP 'BAD DET, INVDET'
        ENDIF
        RETURN
      ENDIF
C-->  2-D
      IF  ( NSPACE .EQ. 2 )  THEN
        CALL  I2BY2 (AJ,AJINV,DET)
        RETURN
      ENDIF
C-->  3-D
      IF  ( NSPACE .EQ. 3 )  THEN
        CALL  I3BY3 (AJ,AJINV,DET)
        RETURN
      ENDIF
      STOP 'BAD NSPACE, INVDET'
      END
      SUBROUTINE  INVECT (NDFREE, NG, CC, M, TOTAL)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     INPUT SPECIFIED VALUES IN FORCING VECTOR, CC
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( NCRD = 5, NPRT = 6 )
      DIMENSION  CC(NDFREE), TOTAL(NG)
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NG     = NUMBER OF PARAMETERS PER NODE
C     CC     = SYSTEM EQUATIONS COLUMN MATRIX
C     M      = TOTAL NUMBER OF NODES IN THE SYSTEM
      DO 5  I = 1, NG
 5    TOTAL(I) = 0.0
      WRITE (NPRT,5000)
 5000 FORMAT ( /, '*** INITIAL FORCING VECTOR DATA ***',/,
     1'     NODE   PARAMETER     VALUE    EQUATION')
      DO  10  I = 1, NDFREE
        READ (NCRD,5010)  NODE, IPARM, VALUE
 5010   FORMAT  ( 2I10, F15.4 )
C        FIND CORRESPONDING DEGREE OF FREEDOM NUMBER
        CALL  DEGPAR (NODE,IPARM,NG,J)
        CC(J)        = VALUE
        TOTAL(IPARM) = TOTAL(IPARM) + VALUE
C       LIST INPUT DATA
        WRITE (NPRT,5020) NODE, IPARM, VALUE, J
 5020   FORMAT ( 2I10, 1X, 1PE13.5, I8)
        IF ( NODE .GT. M .OR. IPARM .GT. NG )  
     1       STOP 'NODE OR IPARM DATA ERROR, INVECT'
        IF ( J .EQ. NDFREE )  GO TO 20
 10   CONTINUE
 20   WRITE (6,5030)
 5030 FORMAT ('*RESULTANTS*',/,
     1        'DOF       SUM')
      DO 40  J = 1, NG
   40 WRITE (6,5040) J, TOTAL(J)
 5040 FORMAT ( I3, 2X, 1PE12.4 )
      RETURN
      END
      SUBROUTINE  INVERT (N, A, B, C)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     INVERSION OF NONSYMMETRIC MATRIX A(N,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8  (A-H,O-Z)
      DIMENSION  A(N,N), B(N), C(N)
C     A   IS DESTROYED AND REPLACED BY ITS INVERSE
C     B,C = ARE WORKING SPACE VECTORS
C     N   = SIZE OF GIVEN MATRIX
      NN = N - 1
      IF ( A(1,1) .EQ. 0.0 ) STOP 'ZERO PIVOT IN INVERT'
      A(1,1) = 1./A(1,1)
      DO 11 M = 1, NN
        K = M + 1
    1   DO 3 I = 1, M
          B(I) = 0.
          DO 2 J = 1, M
    2     B(I) = B(I) + A(I,J)*A(J,K)
    3   CONTINUE
        D  =  0.0
        DO 4 I = 1, M
    4   D = D + A(K,I)*B(I)
        D = -D + A(K,K)
        IF ( D .EQ. 0.0 ) STOP 'ZERO PIVOT IN INVERT'
        A(K,K) = 1./D
        DO 5 I = 1, M
    5   A(I,K) = -B(I)*A(K,K)
        DO 7 J = 1, M
          C(J) = 0.
          DO 6 I = 1, M
    6     C(J) = C(J) + A(K,I)*A(I,J)
    7   CONTINUE
        DO 8 J = 1, M
    8   A(K,J) = -C(J)*A(K,K)
        DO 10  I = 1, M
          DO 9 J = 1, M
    9     A(I,J) = A(I,J)-B(I)*A(K,J)
   10   CONTINUE
   11 CONTINUE
      RETURN
      END
      SUBROUTINE  IPRINT (M, NR, NC)
C     * * * * * * * * * * * * * * * * * * * * * * *
C        PRINTING OF AN INTEGER ARRAY M(NR,NC)
C     * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( NPRT = 6, MAX = 10 )
      DIMENSION  M(1), NCOL(MAX)
      DO 30  J = 1,NC,MAX
        JL1 = J - 1
        MAXCOL = 1
        K = NC - JL1
        MAXCOL = MIN0 (K,MAX)
        MXCLL1 = MAXCOL - 1
        DO 10  L = 1,MAXCOL
   10   NCOL(L) = L + JL1
        WRITE (NPRT,5000)  ( NCOL(N),N=1,MAXCOL )
 5000   FORMAT ('ROW/COL',I7, 9I10 )
        DO 20  N = 1,NR
          NL = N + (J-1)*NR
          NH = NL + MXCLL1*NR
          WRITE (NPRT,5010)  N,( M(I),I=NL,NH,NR )
 5010     FORMAT ( I4, 10I10 )
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  IREMRK (ISAY)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     READ AND PRINT ISAY CARDS FOR USER REMARKS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  REMARK(20)
      WRITE (6,*) ' '
      WRITE (6,*) 'NEXT ', ISAY,' LINES ARE USER SUPPLIED'
      DO 10  I = 1,ISAY
        READ  (5,5010)  REMARK
        WRITE (6,5010)  REMARK
 5010   FORMAT (20A4)
   10 CONTINUE
      WRITE (6,*) ' '
      RETURN
      END
      SUBROUTINE  ISOPAR (N, NSPACE, NELFRE, NIP, SQ, COL, 
     1                    QPT, QWT, H, DLH, DGH, COORD, 
     2                    XPT, AJ, AJINV, NTAPE1, NGRAND,
     3                    LSHAPE, NG, LNODE, IE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C       NUMERICAL INTEGRATION IN AN ISOPARAMETRIC ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
CDP   ABS(Z) = DABS(Z)
      EXTERNAL  NGRAND
      PARAMETER ( ZERO = 0.0 )
      DIMENSION COL(NELFRE), SQ(NELFRE,NELFRE), QWT(0:NIP), 
     1          QPT(NSPACE,0:NIP), H(N), DLH(NSPACE,N), 
     2          DGH(NSPACE,N), COORD(N,NSPACE), XPT(NSPACE), 
     3          AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), LNODE(N)
c23456789012345678901234567890123456789012345678901234567890-----------X
C     IE     = ELEMENT NUMBER
C     N      = NUMBER OF NODES PER ELEMENT
C     NSPACE = NUMBER OF SPATIAL DIMENSIONS
C     NELFRE = NUMBER OF ELEMENT DEGREES OF FREEDOM
C     NIP    = NUMBER OF INTEGRATION POINTS
C     QPT    = QUADRATURE PT COORDS
C     QWT    = QUADRATURE PT WEIGHT
C     SQ     = PROB DEPENDENT SQ MATRIX
C     COL    = PROB DEPENDENT COLUMN MATRIX 
C     H      = ELEMENT INTERPOLATION FUNCTIONS
C     DLH    = LOCAL DERIVATIVES OF H
C     DGH    = GLOBAL DERIVATIVES OF H
C     COORD  = GLOBAL COORD OF NODES OF ELEMENT
C     XPT    = GLOBAL COORD OF QUADRATURE POINT
C     AJ     = JACOBIAN MATRIX
C     AJINV  = JACOBIAN INVERSE
C     DET    = JACOBIAN DETERMINANT
C     NTAPE1 = STORAGE UNIT FOR POST SOLUTION DATA
C     NGRAND = 'EXTERNAL' PROB DEP INTEGRAND ROUTINE
C-->   ZERO INTEGRANDS
      CALL  ZEROA (NELFRE,COL)
      CALL  ZEROA (NELFRE*NELFRE,SQ)
C-->   BEGIN INTEGRATION
      IWARN = 0
c     write(6,*) 'isopar'
c     call rprint(qpt,nspace,nip+1,0)
c     call rprint(qwt,1,nip+1,0)
      DO 100  IP = 1, NIP
C        EVALUATE INTERPOLATION FUNCTIONS
        CALL  SHAPE (QPT(1,IP), H, N, NSPACE, LSHAPE, NG, LNODE)
C        FIND GLOBAL COORD, XPT = H*COORD
        CALL  MMULT (H, COORD, XPT, 1, N,NSPACE)
C        FIND LOCAL DERIVATIVES
        CALL  DERIV (QPT(1,IP), DLH, N, NSPACE, LSHAPE, NG, LNODE)
C        FIND JACOBIAN AT THE PT
        CALL  JACOB (N, NSPACE, DLH, COORD, AJ)
C        FORM INVERSE AND DETERMINATE OF JACOBIAN
        CALL  INVDET (AJ, AJINV, DET, NSPACE)
        IF ( DET .LT. ZERO )  THEN
          IWARN = IWARN + 1
          DET = ABS( DET )
        ENDIF
C        EVALUATE GLOBAL DERIVATIVES
        CALL  GDERIV (NSPACE, N, AJINV, DLH, DGH)
c       if ( ip .eq. 1 )  then
c         call rprint(dgh, nspace, n, 0)
c         call rprint(dlh, nspace, n, 0)
c         call rprint(h, 1, n, 0)
c         write(6, *) det,  qwt
c       endif
C      *** FORM PROBLEM DEPENDENT INTEGRANDS ***
        CALL  NGRAND (QWT(IP), DET, H, DGH, XPT, N, 
     1                NSPACE, NELFRE, COL, SQ, NTAPE1)
 100  CONTINUE
      IF ( IWARN .GT. 0 )  WRITE (6,*)
     1 'WARNING, NEGATIVE JACOBIAN CORRECTED, IE =', IE
      RETURN
      END
      SUBROUTINE  JACOB (N, NSPACE, DELTA, COORD, AJ)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      CALCULATE THE JACOBIAN MATRIX AT A LOCAL POINT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DELTA(NSPACE,N), COORD(N,NSPACE),
     1           AJ(NSPACE,NSPACE)
C     N      = NUMBER OF NODES PER ELEMENT
C     NSPACE = DIMENSION OF SPACE
C     DELTA  = LOCAL  DERIVATIVES OF N INTERPOLATION
C              FUNCTIONS AT POINT OF INTEREST.
C     COORD  = SPATIAL COORDINATES OF ELEMENT'S NODES
C     AJ     = JACOBIAN MATRIX = DELTA*COORD
      DO 30  I = 1, NSPACE
        DO 20  J = 1, NSPACE
          SUM = 0.0
          DO 10  K = 1, N
            SUM = SUM + DELTA(I,K)*COORD(K,J)
 10       CONTINUE
        AJ(I,J) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  LAME (NPARM, NSPACE, GRAD, RE, F, RG, H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C            GET THE LAME PARAMETERS, E F G AND H, AT PT 
C                 ON PARAMETRIC CURVE OR SURFACE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  GRAD(NPARM, NSPACE)
C     N      = NUMBER OF NODES PER ELEMENT
C     NPARM  = NUMBER OF PARAMETRIC DIMENSIONS <= NSPACE
C     NSPACE = DIMENSION OF PHYSICAL SPACE
C     DELTA  = LOCAL  DERIVATIVES OF N INTERPOLATION
C              FUNCTIONS AT POINT OF INTEREST.
C     COORD  = SPATIAL COORDINATES OF ELEMENT'S NODES
C     GRAD   = TANGENT MATRIX FROM TANVEC 
C              FOR NPARM = NSPACE, GRAD = JACOBIAN
C     RE     = SQUARE ROOT OF E, E = X,R^2 + Y,R^2 + Z,R^2
C     RF     = SQUARE ROOT OF F, F = X,S*X,R + Y,S*Y,R + Z,S*Z,R
C     RG     = SQUARE ROOT OF G, G = X,S^2 + Y,S^2 + Z,S^2
      IF ( NPARM .GT. 2 ) STOP 'INVALID ARGUMENT, LAME'
      G = 0.
      F = 0.
      E = GRAD(1,1)**2
      IF ( NSPACE .GT. 1 ) E = E + GRAD(1,2)**2
      IF ( NSPACE .EQ. 3 ) E = E + GRAD(1,3)**2
      IF ( NPARM .GT. 1 )  THEN
        G = GRAD(2,1)**2 + GRAD(2,2)**2
        IF ( NSPACE .EQ. 3 ) G = G + GRAD(2,3)**2
        F = GRAD(1,1)*GRAD(2,1) + GRAD(1,2)*GRAD(2,2)
        IF ( NSPACE .EQ. 3 ) F = F + GRAD(1,3)*GRAD(2,3)
      ENDIF
      H = SQRT ( E*G - F*F )
      RG = SQRT (G)
      RE = SQRT (E)
      RETURN
      END
      SUBROUTINE  LASTL (M, N, NE, NODES, LNODE, LFIRST, 
     1                   LLAST, IWARN)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FIND ELEMENT OF FIRST & LAST APPEARANCE OF EACH NODE
C                 ( VECTOR VERSION IN LASTLV )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  NODES(NE,N),  LNODE(N),  LFIRST(M),  LLAST(M)
C     M         = TOTAL NUMBER OF NODES IN SYSTEM
C     N         = NUMBER OF NODES PER ELEMENT
C     NE        = NUMBER OF ELEMENTS IN THE SYSTEM
C     NODES     = SYSTEN ARRAY OF ALL ELEMENT INCIDENCES
C     LNODE     = INCIDENCES ARRAY OF A SINGLE ELEMENT
C     LFIRST(I) = ELEMENT OF FIRST APPEARANCE OF NODE I
C     LLAST(I)  = ELEMENT OF LAST APPEARANCE OF NODE I
C     IF IWARN.NE.0  WARN OF NODES WITH NO ELEMENTS
      DO 10  I = 1, M
         LFIRST(I) = 0
   10    LLAST(I) = 0
      DO 30  J = 1, NE
C        EXTRACT ELEMENT'S NODES
        CALL  LNODES (J, NE, N, NODES, LNODE)
C        SCAN THE NODES
        DO 20  I = 1, N
          L = LNODE(I)
          IF ( L .LT. 1 )  GO TO 20
            IF ( LFIRST(L) .EQ. 0 )  LFIRST(L) = J
            LLAST(L) = J
   20   CONTINUE
   30 CONTINUE
      IF ( IWARN .EQ. 0 )  RETURN
C      WARN OF NODES WITH NO ELEMENT CONNECTIONS
      DO 40  I = 1, M
        IF ( LFIRST(I) .GT. 0 )  GO TO 40
        WRITE (6, 5000)  I
 5000   FORMAT ('WARNING, NODE ', I4, ' DOES NOT OCCUR IN ', 
     1          'THE ELEMENT INCIDENCES LIST')
   40   CONTINUE
      RETURN
      END
       SUBROUTINE LCONTR (RINOUT, SINOUT, V, COORD, XYZ, N, 
     1                    NSPACE, KOUNT, H, DH, LTYPE )
C      * * * * * * * * * * * * * * * * * * * * * * * * * *
C      CALCULATE COORDINATES OF POINTS ON A CONTOUR
C        ON AN ISOPARAMETRIC SURFACE
C      * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP     IMPLICIT REAL*8 (A-H,O-Z)
       PARAMETER  ( MAX = 300, TRYDL = 0.005 )
       DIMENSION  COORD(N,NSPACE), V(N), H(N), DH(2,N),
     1     PXYZ(3), XYZ(MAX,NSPACE), R(MAX), S(MAX), DER(2)
       EQUIVALENCE (PXYZ(1),DER(1),DVDR), (DER(2),DVDS)
C      MAX    = MAX. NO. CONTOUR POINTS
C      DL     = LOCAL COORD. LENGTH OF EACH SEGMENT
C      KOUNT  = NO. OF PTS. ON CONTOUR CURVE
C      R,S    = LOCAL COORDINATES
C      XYZ    = GLOBAL COORD. ARRAY FOR COUNTOUR PTS.
C      PXYZ   = GLOBAL COORDINATES OF A SINGLE POINT
C      COORD  = GLOBAL COORD. OF NODES OF ELEMENT
C      N      = NUMBER OF NODES PER ELEMENT
C      NSPACE = DIMENSION OF GLOBAL SPACE, 2 OR 3
C      RINOUT,SINOUT = COORD OF 1ST (IN) OR LAST (OUT) PT
C      H      = ELEMENT INTERPOLATION FUNCTIONS
C      DH     = LOCAL COORD. DERIVATIVES OF H
C      V      = NODAL VALUES OF QUANTITY TO BE CONTOURED
C      LTYPE  = ELEM. TYPE, 0=QUADRILATERAL, 1=TRIANGLE
CDP     SQRT(Z) = DSQRT(Z)
CDP     ABS(Z) = DABS(Z)
       KOUNT = 1
       DL    = TRYDL
       IF ( LTYPE .EQ. 0 )  DL = DL*2.0
C-->    LOCAL COORDINATE CALCULATIONS
       R(1) = RINOUT
       S(1) = SINOUT
C      MARCH ALONG CONTOUR
    5   CONTINUE
C      FORM SHAPE FUNCTION LOCAL DERIVATIVES
       CALL DERIV (R(KOUNT),S(KOUNT),DH)
C      FORM LOCAL DERIVATIVE OF VARIABLE, DER = DH*V
       CALL MMULT (DH,V,DER,2,N,1)
       GRAD = SQRT( DVDR*DVDR + DVDS*DVDS )
C      FIND LOCAL COORD. OF SEGMENT END
       RNEW = R(KOUNT) - DL*DVDS/GRAD
       SNEW = S(KOUNT) + DL*DVDR/GRAD
C      IS NEXT POINT IN THE ELEMENT
       IF ( LTYPE .EQ. 0 )  THEN    
C         QUADRILATERAL (-1 TO +1): IS POINT OUTSIDE ?
   10    IF ( ABS(RNEW) .GT. 1.0 .OR. ABS(SNEW) .GT. 1.0 )  
     1        GO TO 20
       ELSE
C         TRIANGLE (UNIT COORDINATES): OUTSIDE ?
         IF ( RNEW .LT. 0.0 .OR. SNEW .LT. 0.0 .OR.
     1       (RNEW+SNEW) .GT. 1.0 )  GO TO 20
       ENDIF
C      ADD POINT TO CONTOUR LIST
       KOUNT    = KOUNT + 1
       R(KOUNT) = RNEW
       S(KOUNT) = SNEW
       IF ( KOUNT .LT. MAX )  GO TO 5 
C-->    LINE COMPLETED IN LOCAL COORDINATES
   20   CONTINUE
       IF ( KOUNT .EQ. 1)  THEN
         DL = -DL
         GO TO 5
       ENDIF   
C      RETURN LOCAL COORD. OF LAST POINT
       RINOUT = R(KOUNT)
       SINOUT = S(KOUNT)
C-->    CONVERT TO GLOBAL COORDINATES
       DO 25  I = 1, KOUNT
C         EVALUATE SHAPE FUNCTIONS
         CALL SHAPE (R(I),S(I),H)
C         EVALUATE GLOBAL COORDINATES, XYZ = H*COORD
         CALL  MMULT (H,COORD,PXYZ,1,N,NSPACE)
         XYZ(I,1) = PXYZ(1)
         XYZ(I,2) = PXYZ(2)
         IF ( NSPACE .EQ. 3 ) XYZ(I,3) = PXYZ(3)
   25   CONTINUE
C-->    CONTOUR FINISHED, RETURN FOR PLOTTING
       RETURN
       END
      SUBROUTINE  LISTI (LOC1, LOC2, NEXTI, IN, IPT, I)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C       LIST INTEGER SUB-ARRAYS FROM ARRAY LOC1 TO LOC2
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 IN
      DIMENSION  IPT(1), IN(1), I(1)
      PARAMETER ( IONE=1 )
C
C     I     = Main integer arrays
C     IN    = Names of sub-arrays in I array
C     IPT   = pointer array for sub-arrays in I
C     LOC   = Array location. If < 1 list all.
C     NEXTI = Next free sub-array in I
      K1 = 1
      K2 = NEXTI - 1
      IF  ( LOC1 .GE. 1 ) THEN
        K1 = LOC1
        K2 = LOC2
      ENDIF
      WRITE (6,100)
 100  FORMAT ( /,' INTEGER SUB-ARRAY DATA:', /)
      DO 10 K = K1, K2
        ISIZE = IPT(K+1) - IPT(K)
        WRITE (6,200) K, IPT(K), ISIZE, IN(K)
 200    FORMAT ( 'NUMBER =',I3,', BEGIN = ',I5,', SIZE = ',I5,
     1         ', NAME = ', A8,', CONTENTS:' )
        IF ( ISIZE .GT. 0 ) CALL IPRINT (I(IPT(K)),IONE,ISIZE)
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  LISTR (LOC1, LOC2, NEXTR, RN, JPT, R)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        LIST REAL SUB-ARRAYS FROM LOC1 TO LOC2
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 RN
      DIMENSION  JPT(1), RN(1), R(1)
      PARAMETER ( IONE=1 )
C
C     R     = Main integer arrays
C     RN    = Names of sub-arrays in R array
C     JPT   = pointer array for sub-arrays in R
C     LOC   = Array location. If < 1 list all.
C     NEXTR = Next free sub-array in R
C
      K1 = 1
      K2 = NEXTR - 1
      IF  ( LOC1 .GE. 1 ) THEN
        K1 = LOC1
        K2 = LOC2
      ENDIF
      WRITE (6,100)
 100  FORMAT ( /,' REAL SUB-ARRAY DATA:', /)
      DO 10 K = K1, K2
        ISIZE = JPT(K+1) - JPT(K)
        WRITE (6,200) K, JPT(K), ISIZE, RN(K)
 200    FORMAT ( 'NUMBER =',I3,', BEGIN = ',I5,', SIZE = ',I5,
     1         ', NAME = ', A8,', CONTENTS:' )
        IF ( ISIZE .GT. 0 ) CALL RPRINT (R(JPT(K)),IONE,ISIZE,IONE)
 10   CONTINUE
      RETURN
      END
      SUBROUTINE   LNODES (LID, NE, N, NODES, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C          EXTRACT NODES ASSOCIATED WITH ELEMENT LID
C     * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  NODES(NE,N), LNODE(N)
C     NE    = NUMBER OF ELEMENTS IN SYSTEM
C     N     = NUMBER OF NODES PER ELEMENT
C     LID   = ELEMENT NUMBER
C     NODES = NODAL INCIDENCES OF ALL ELEMENTS
C     LNODE = THE N NODAL INCIDENCES OF THE ELEMENT
      DO 10  I = 1, N
 10   LNODE(I) = NODES(LID,I)
      RETURN
      END
      SUBROUTINE  LOBATO (NQP, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOBATTO QUADRATURE ABSCISSAE AND WEIGHT COEFFS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT  REAL*8  PT, WT
      PARAMETER ( NMAX = 10 )
      DIMENSION  PT(0:NQP), WT(0:NQP)
C     NQP  = NO. OF LOBATTO POINTS IN ONE DIMENSION
C     PT   = ABSCISSAE OF LOBATTO POINTS
C     WT   = WEIGHTS  OF LOBATTO POINTS
C     NMAX = MAX. NO. OF POINTS TABULATED HEREIN
      NGP = NQP
      IF ( NGP .GT. NMAX )  THEN
        NGP = NMAX
        WRITE (6,*) 'WARNING, LOBATO USED NGP = ', NMAX
      ENDIF 
      IF ( NGP .LT. 1 ) STOP 'NO POINTS IN LOBATO'
      IF ( NGP .EQ. 1 )  THEN
C...     NGP = 1
        PT( 1) = 0.00000000000000D+00
        WT( 1) = 2.00000000000000D+00
        RETURN
      ELSEIF ( NGP .EQ. 2 )  THEN
C...     NGP = 2
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 1.00000000000000D+00
        PT( 2) = -PT( 1)
        WT( 2) =  WT( 1)
        RETURN
      ELSEIF ( NGP .EQ. 3 )  THEN
C...     NGP = 3
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 3.33333333333333D-01
        PT( 2) = 0.00000000000000D+00
        WT( 2) = 1.33333333333333D+00
        PT( 3) = -PT( 1)
        WT( 3) =  WT( 1)
        RETURN
      ELSEIF ( NGP .EQ. 4 )  THEN
C...     NGP = 4
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 1.66666666666667D-01
        PT( 2) = 4.47213595499958D-01
        WT( 2) = 8.33333333333333D-01
        PT( 3) = -PT( 1)
        WT( 3) =  WT( 1)
        PT( 4) = -PT( 2)
        WT( 4) =  WT( 2)
        RETURN
      ELSEIF ( NGP .EQ. 5 )  THEN
C...     NGP = 5
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 1.00000000000000D-01
        PT( 2) = 6.54653670707977D-01
        WT( 2) = 5.44444444444444D-01
        PT( 3) = 0.00000000000000D+00
        WT( 3) = 7.11111111111111D-01
        PT( 4) = -PT( 1)
        WT( 4) =  WT( 1)
        PT( 5) = -PT( 2)
        WT( 5) =  WT( 2)
        RETURN
      ELSEIF ( NGP .EQ. 6 )  THEN
C...     NGP = 6
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 6.66666666666667D-02
        PT( 2) = 7.65055323929465D-01
        WT( 2) = 3.78474956297847D-01
        PT( 3) = 2.85231516480645D-01
        WT( 3) = 5.54858377035486D-01
        PT( 4) = -PT( 1)
        WT( 4) =  WT( 1)
        PT( 5) = -PT( 2)
        WT( 5) =  WT( 2)
        PT( 6) = -PT( 3)
        WT( 6) =  WT( 3)
      ELSEIF ( NGP .EQ. 7 )  THEN
C...     NGP = 7
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 4.7619047619048D-02
        PT( 2) = 8.30223896278567D-01
        WT( 2) = 2.76826047361566D-01
        PT( 3) = 4.68848793470714D-01
        WT( 3) = 4.31745381209863D-01
        PT( 4) = 0.00000000000000D+00
        WT( 4) = 4.87619047619048D-01
        PT( 5) = -PT( 1)
        WT( 5) =  WT( 1)
        PT( 6) = -PT( 2)
        WT( 6) =  WT( 2)
        PT( 7) = -PT( 3)
        WT( 7) =  WT( 3)
        RETURN
      ELSEIF ( NGP .EQ. 8 )  THEN
C...     NGP = 8
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 3.5714285714286D-02
        PT( 2) = 8.71740148509607D-01
        WT( 2) = 2.10704227143506D-01
        PT( 3) = 5.91700181433142D-01
        WT( 3) = 3.41122692483504D-01
        PT( 4) = 2.09299217902479D-01
        WT( 4) = 4.12458794658704D-01
        PT( 5) = -PT( 1)
        WT( 5) =  WT( 1)
        PT( 6) = -PT( 2)
        WT( 6) =  WT( 2)
        PT( 7) = -PT( 3)
        WT( 7) =  WT( 3)
        PT( 8) = -PT( 4)
        WT( 8) =  WT( 4)
        RETURN
      ELSEIF ( NGP .EQ. 9 )  THEN
C...     NGP = 9
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 2.77777777777778D-02
        PT( 2) = 8.99757995411460D-01
        WT( 2) = 1.65495361560805D-01
        PT( 3) = 6.77186279510738D-01
        WT( 3) = 2.74538712500162D-01
        PT( 4) = 3.63117463826178D-01
        WT( 4) = 3.46428510973406D-01
        PT( 5) = 0.00000000000000D+00
        WT( 5) = 3.71519274376417D-01
        PT( 6) = -PT( 1)
        WT( 6) =  WT( 1)
        PT( 7) = -PT( 2)
        WT( 7) =  WT( 2)
        PT( 8) = -PT( 3)
        WT( 8) =  WT( 3)
        PT( 9) = -PT( 4)
        WT( 9) =  WT( 4)
        RETURN
      ELSEIF ( NGP .EQ. 10 )  THEN
C...     NGP = 10
        PT( 1) = 1.00000000000000D+00
        WT( 1) = 2.22222222222222D-02
        PT( 2) = 9.19533908166459D-01
        WT( 2) = 1.33305990851070D-01
        PT( 3) = 7.38773865105505D-01
        WT( 3) = 2.24889342063126D-01
        PT( 4) = 4.77924949810444D-01
        WT( 4) = 2.92042683679684D-01
        PT( 5) = 1.65278957666387D-01
        WT( 5) = 3.27539761183897D-01
        PT( 6) = -PT( 1)
        WT( 6) =  WT( 1)
        PT( 7) = -PT( 2)
        WT( 7) =  WT( 2)
        PT( 8) = -PT( 3)
        WT( 8) =  WT( 3)
        PT( 9) = -PT( 4)
        WT( 9) =  WT( 4)
        PT(10) = -PT( 5)
        WT(10) =  WT( 5)
        RETURN
      ENDIF
      RETURN
      END
      SUBROUTINE  LPTPRT (N, M, NNPFLO, FLTNP, PRTLPT, 
     1               NNPFIX, NPFIX, LPPROP, LNODE, NHOMO)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT FLOATING POINT PROPERTIES AT NODAL POINTS
C                      OF AN ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  FLTNP(M,0:NNPFLO), PRTLPT(N,0:NNPFLO), 
     1           NPFIX(M,0:NNPFIX), LPPROP(N,0:NNPFIX),
     2           LNODE(N)
C     FLTNP  = FLOATING POINT PROP ARRAY OF SYSTEM NODES
C     PRTLPT = FLOATING POINT PROP ARRAY OF ELEMENT NODES
C     NPFIX  = INTEGER PROPERTY ARRAY OF SYSTEM NODES
C     LPPROP = INTEGER PROPERTY ARRAY OF ELEMENT NODES
C     LNODE  = ELEMENT INCIDENCES ARRAY OF THE ELEMENT
C     M      = NUMBER OF SYSTEM NODES
C     N      = NUMBER OF NODES PER ELEMENT
C     NNPFIX = NUMBER OF INTEGER PROPERTIES PER NODE
C     NNPFLO = NUMBER OF REAL PROPERTIES PER NODE
C     NHOMO  = 1, IF PROPERTIES ARE SAME AT EACH NODE
      DO 20  I = 1, N
        IROW = LNODE(I)
C        ALLOW FOR OMITTED NODES
        IF ( IROW .GT. 0 )  THEN
          IF ( NHOMO .EQ. 1 )  IROW = 1
          IF ( NNPFLO .GT. 0 )  THEN
            DO 10  J = 1, NNPFLO
 10         PRTLPT(I,J) = FLTNP(IROW,J)
          ENDIF
          IF ( NNPFIX .GT. 0 )  THEN
            DO 30  J = 1, NNPFIX
 30         LPPROP(I,J) = NPFIX(IROW,J)
          ENDIF
        ENDIF
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  MADD (A, B, C, M, N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        MATRIX ADDITION   A(M,N)+B(M,N)=C(M,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8  (A-H,O-Z)
      DIMENSION  A(M*N), B(M*N), C(M*N)
      MN = M*N
      DO 10  I = 1,MN
 10   C(I) = A(I) + B(I)
      RETURN
      END
      SUBROUTINE  MATPRT (NUM,NLPFLO,MISCFL,FLTMIS,PRTMAT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        EXTRACT REAL MATERIAL PROPERTIES OF MATERIAL
C       NUM FROM MISCELLANEOUS REAL SYSTEM PROPERTIES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  FLTMIS(0:MISCFL), PRTMAT(0:NLPFLO)
C     NUM    = MATERIAL NUMBER
C     NMAX   = MAXIMUM ALLOWABLE MATERIAL NUMBER
C     NLPFLO = NUMBER OF REAL ELEMENT PROPERTIES
C     MISCFL = NO OF MISC REAL SYSTEM PROPERTIES
C     FLTMIS = SYSTEM STORAGE FOR MISC REAL PROP
C     PRTMAT = REAL PROPERTY ARRAY FOR MATERIAL NUM
C      PROPERTIES ARE STORED IN FLTMIS IN ORDER OF MAT NO
      IF ( NLPFLO .LT. 1 ) STOP 'BAD NLPFLO, MATPRT'
      NMAX = MISCFL/NLPFLO
      IF ( NUM .GT. NMAX ) STOP 'DIMENSIONS EXCEEDED, MATPRT'
      ISTART = NLPFLO*(NUM - 1)
      DO 10  I = 1, NLPFLO
   10 PRTMAT(I) = FLTMIS(ISTART+I)
      RETURN
      END
      SUBROUTINE  MATWRT (NLPFLO,MISCFL,FLTMIS,PRTMAT)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C          LIST REAL PROPERTIES BY MATERIAL NUMBER
C     * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  FLTMIS(0:MISCFL), PRTMAT(0:NLPFLO)
C     NLPFLO = NUMBER OF REAL ELEMENT PROP
C     MISCFL = NUMBER OF MISC REAL SYSTEM PROP
C     FLTMIS = SYSTEM STORAGE OF MISC REAL PROP
C     PRTMAT = REAL PROP ARRAY FOR MATERIAL NUM
C     NMAX   = MAXIMUM ALLOWABLE MATERIAL NUMBER
      IF ( NLPFLO .LT. 1 .OR. NLPFLO .GT. MISCFL ) THEN
        WRITE (NPRT,*)  NLPFLO, MISCFL
        STOP 'BAD NLPFLO, MATWRT'
      ENDIF
      NMAX = MISCFL/NLPFLO
      WRITE (NPRT,5000)  NLPFLO
 5000 FORMAT ( /, '** LIST OF REAL MATERIAL PROPERTIES **',/,
     2'MATERIAL,',I4,' REAL PROPERTIES')
      DO 10  I = 1, NMAX
        CALL  MATPRT (I,NLPFLO,MISCFL,FLTMIS,PRTMAT)
        WRITE (NPRT,5010) I, (PRTMAT(J), J=1,NLPFLO)
 5010   FORMAT ( I5, (10(1PE12.4)) )
   10 CONTINUE
      RETURN
      END
      SUBROUTINE  MAXMIN (M, NG, NDFREE, IPRINT, RANGE, DD, 
     1                    INDEX, NRANGE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      FIND EXTREME RANGE OF VALUES OF THE NG NODAL DOF
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  DD(NDFREE), RANGE(NG,2), INDEX(NG),
     1           NRANGE(NG,2)
C     M      = NUMBER OF NODES IN SYSTEM
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     IPRINT > 0 PRINT RANGE OF VALUES
C     RANGE  : 1-MAXIMUM VALUE, 2-MINIMUM VALUE
C     DD     = ARRAY OF SYSTEM DEGREES OF FREEDOM
C     INDEX  = LIST OF SYSTEM DOF NOS FOR DOF AT NODE
C     NRANGE = ARRAY OF NODE NOS OF EXTREME VALUE POINTS
      DO 10  J = 1, NG
        NRANGE(J,1) = 0
        NRANGE(J,2) = 0
        RANGE(J,1) = DD(J)
 10   RANGE(J,2) = DD(J)
      DO 40  I = 1, M
        CALL  INDXPT (I,NG,INDEX)
        DO 30  J = 1,NG
          DDTEST = DD(INDEX(J))
          IF ( DDTEST .LT. RANGE(J,1) )  GO TO 20
            RANGE(J,1)  = DDTEST
            NRANGE(J,1) = I
 20         IF ( DDTEST.GT.RANGE(J,2) )  GO TO 30
              RANGE(J,2)  = DDTEST
              NRANGE(J,2) = I
 30     CONTINUE
 40   CONTINUE
      IF ( IPRINT .EQ. 0 )  RETURN
C        PRINT RANGE OF VALUES
        WRITE (NPRT,5000)
 5000   FORMAT ( /,
     1  '*** EXTREME VALUES OF THE NODAL PARAMETERS ***',/,
     2  'PARAMETER    MAXIMUM, NODE      MINIMUM, NODE')
        DO 50  J = 1, NG
 50       WRITE (NPRT,5010) J, RANGE(J,1), NRANGE(J,1), 
     1                         RANGE(J,2), NRANGE(J,2)
 5010   FORMAT (I7,2X,1PE11.4,',',I5,2X,1PE11.4,',',I5)
        RETURN
        END
      SUBROUTINE  MMDIFF  (A, B, C, D, L, M, N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     PRODUCT OF MATRIX TIMES DIFFERENCE IN MATRICES
C     D(L,N) = A(L,M) * ( B(M,N) - C(M,N) )
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( ZERO = 0.0 )
      DIMENSION A(L,M), B(M,N), C(M,N), D(L,N)
      DO 30  I = 1, L
        DO 20  J = 1, N
          SUM = ZERO
          DO 10  K = 1, M
            BKJ = B(K,J) - C(K,J)
            IF ( BKJ .EQ. ZERO )  GO TO 10
              AIK = A(I,K)
              IF ( AIK .EQ. ZERO )  GO TO 10
                SUM = SUM + AIK*BKJ
 10       CONTINUE
        D(I,J) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  MMULT (A, B, C, L, M, N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      MATRIX MULTIPLICATION: A(L,M) * B(M,N) = C(L,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( ZERO = 0.0 )
      DIMENSION A(L,M), B(M,N), C(L,N)
      DO 30  I = 1, L
        DO 20  J = 1, N
          SUM = ZERO
          DO 10  K = 1, M
            BKJ = B(K,J)
            IF ( BKJ .EQ. ZERO )  GO TO 10
              AIK = A(I,K)
              IF ( AIK .EQ. ZERO )  GO TO 10
                SUM = SUM + AIK*BKJ
 10       CONTINUE
        C(I,J) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  MODEL92 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI,
     1     NEXTR, NEXTI, RARRAY, RNAME, IARRAY, INAME,
     2     JRARAY, JIARAY,
     A     TITLE, NSEG, LBN, NITER, NCURVE, INRHS, ISAY, NNPFIX, 
     B     NLPFIX, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, 
     C     NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, MAXTYP, 
     D     NLTYPE, NUMCE, IPTEST, LPTEST, MODE, M, MAXACT, MISCFL, 
     E     MISCFX, N, NC, NCOEFF, NDFREE, NE, NELFRE, NGF, NFLUX, 
     F     NG, NGEOM, NLPFLO, NNPFLO, NOMAT, NPARM, NPLT, NQP, NRB, 
     G     NSEG, NSPACE, NSYS, NTMP, NUMCE, LSHAPE, IBUG,
     H     NBSFIX, NBSFLO,
     3     X, AJ, AJINV, AVE, B, BODY, C, CC, CEQ, COORD, D,
     4     DDOLD, DGH, DLG, DLH, E, EB, ELPROP, FLTEL, FLTBS,
     5     FLTMIS, FLTNP, FLUX, FLUXBS, G, GPT, GWT, H, HINTG,
     6     PLTSET, PRTLPT, PRTMAT, PT, RANGE, S, SATPT, STRAIN,
     7     STRAN0, STRESS, SYSDAT, TMP, VALC, VALE, WT, XPT, XYZ,
     8     DD, USEREL, USERPT, SS, 
     9     IBC, KODES, NODES, NRES, LTYPE, IADD, IDIAG, 
     1     INDEX, LFIRST, LLAST, LNODE, LPFIX, NBSPFX, LPPROP, 
     2     LPROP, LTDATA, MISFIX, NDXC, NODEF, NRANGE, NREQ, 
     3     NPFIX, LHIGH )
c        1         2         3         4         5         6         712
c23456789012345678901234567890123456789012345678901234567890-----------X
C
C     ******************************************************
C     *                   -M-O-D-E-L-                      *
C     *    MODULAR PROGRAMS FOR FINITE ELEMENT ANALYSES    *
C     *           COPYRIGHT J. E. AKIN, 1992               *
C     ******************************************************
C
C              A SET OF BUILDING BLOCK PROGRAMS
C                            BY
C                      DR. J. E. AKIN, P.E.
C      DEPT. OF MECHANICAL ENGINEERING & MATERIALS SCIENCE
C                        RICE UNIVERSITY
C                   HOUSTON, TEXAS 77251-1892
C  
C                      email: akin@rice.edu
C 
C WARNING: USE COMPILE FLAG FOR EXTRA CONTINUATIONS: -Nl40
C
      PARAMETER  ( NREACT = 20, CUTOFF = 1.E-6 )
      LOGICAL    FACT, BACK
      DIMENSION  TITLE(15), RARRAY(MAXR), RNAME(NUMR),         
     1  X(M,NSPACE), AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE),
     2  AVE(0:M,NRB+2), B(NRB,NELFRE), BODY(NSPACE), C(NELFRE),
     3  CC(NDFREE), CEQ(MAXACT,NUMCE), COORD(N,NSPACE), D(NELFRE),
     4  DDOLD(NDFREE), DGH(NSPACE,N,0:NQP), DLG(NPARM,NGEOM,0:NQP),
     5  DLH(NSPACE,N,0:NQP), E(NRB,NRB), EB(NRB,NELFRE), 
     6  ELPROP(0:NLPFLO), FLTEL(NE,0:NLPFLO), FLTBS(0:NSEG,0:NBSFLO), 
     7  FLTMIS(0:MISCFL), FLTNP(M,0:NNPFLO), FLUX(0:NGF), 
     8  FLUXBS(0:NSEG,0:NFLUX), G(NGEOM,0:NQP), GPT(0:NQP), GWT(0:NQP)
      DIMENSION  H(N,0:NQP), HINTG(N,0:NQP+1), PLTSET(0:NPLT), 
     1  PRTLPT(N,0:NNPFLO), PRTMAT(0:NLPFLO,0:NOMAT), PT(NPARM,0:NQP), 
     2  RANGE(NG,2), S(NELFRE,NELFRE), SATPT(NRB+2,N), 
     3  STRAIN(NRB+2),STRAN0(NRB), STRESS(NRB+2), SYSDAT(0:NSYS), 
     4  TMP(0:NTMP), VALC(NRB,0:NC), VALE(NRB,0:NC), WT(0:NQP), 
     5  XPT(NSPACE,2), XYZ(NSPACE), DD(NDFREE), USEREL(NG,N),
     6  USERPT(NG), SS(1)
      DIMENSION  IARRAY(MAXI), INAME(NUMI), IBC(M), KODES(NG), 
     1  NODES(NE,N), NRES(MAXTYP), LTYPE(NE), IADD(0:M), 
     2  IDIAG(NDFREE), INDEX(NELFRE), LFIRST(M), LLAST(M), LNODE(N), 
     3  LPFIX(NE,0:NLPFIX), NBSPFX(0:NSEG,0:NBSFIX), LPPROP(0:NNPFIX), 
     4  LPROP(0:NLPFIX), LTDATA(6,NLTYPE), MISFIX(0:MISCFX), 
     5  NDXC(MAXACT,NUMCE), NODEF(0:NSEG,0:LBN), NRANGE(NG,2), 
     6  NREQ(MAXTYP), NPFIX(M,0:NNPFIX), LHIGH(NELFRE)
c        1         2         3         4         5         6         712
c23456789012345678901234567890123456789012345678901234567890-----------X
C     ...................... NOTATION ......................
C     SEE TEXT OR notation.f
C     ......................................................
      IF ( IBUG .EQ. 1 )  THEN
        WRITE (6,5030) M, NE, NG, N, NSPACE, NSEG, LBN, NGF,
     1                 NITER, NCURVE, INRHS, ISAY, NRB, NQP, 
     2                 LSHAPE, NLTYPE, MODE
 5030 FORMAT ( /, '*****  PROBLEM PARAMETERS  *****',/,
     1 'NUMBER OF NODAL POINTS IN SYSTEM ........',I5,/,
     2 'NUMBER OF ELEMENTS IN SYSTEM ............',I5,/,
     4 'NUMBER OF PARAMETERS PER NODE ...........',I5,/,
     3 'NUMBER OF NODES PER ELEMENT .............',I5,/,
     5 'DIMENSION OF SPACE ......................',I5,/,
     6 'NUMBER OF BOUNDARIES WITH GIVEN FLUX ....',I5,/,
     7 'NUMBER OF NODES ON BOUNDARY SEGMENT .....',I5,/,
     8 'NUMBER OF FLUX COMPONENTS PER NODE.......',I5,/,
     8 'NUMBER OF ITERATIONS TO BE RUN ..........',I5,/,
     9 'NUMBER OF CONTOURS BETWEEN 5 & 95% ......',I5,/,
     + 'INITIAL FORCING VECTOR INPUT FLAG .......',I5,/,
     1 'NUMBER OF USER REMARKS LINES ............',I5,/,
     2 'NUMBER OF ROWS IN B MATRIX ..............',I5,/,
     3 'NUMBER OF QUADRATURE POINTS .............',I5,/,
     4 'SHAPE 1-LINE 2-TRI 3-QUAD 4-HEX 5-TET ...',I5,/,
     5 'NUMBER OF DIFFERENT ELEMENT TYPES .......',I5,/,
     6 'STIFFNESS STORAGE MODE: SKY, BAND .......',I5)
      IF ( LBN .GT. N )    WRITE (6,*)
     1    'INCONSISTANT VALUES OF LBN AND N.'
      WRITE (6,5080) NNPFIX, NNPFLO, NLPFIX, NLPFLO, 
     1               NBSFIX, NBSFLO, MISCFX, MISCFL
 5080 FORMAT (
     1 'NUMBER OF INTEGER PROPERTIES PER NODE .......',I5,/,
     2 'NUMBER OF REAL PROPERTIES PER NODE ..........',I5,/,
     3 'NUMBER OF INTEGER PROPERTIES PER ELEMENT ....',I5,/,
     4 'NUMBER OF REAL PROPERTIES PER ELEMENT .......',I5,/,
     3 'NUMBER OF INTEGER PROPERTIES PER SEGMENT ....',I5,/,
     4 'NUMBER OF REAL PROPERTIES PER SEGMENT .......',I5,/,
     5 'NUMBER OF INTEGER MISCELLANEOUS  PROPERTIES .',I5,/,
     6 'NUMBER OF REAL MISCELLANEOUS  PROPERTIES ....',I5)
      WRITE (6,5081) NELFRE, NFLUX, NDFREE
 5081 FORMAT (
     1 'NUMBER OF D.O.F. FOR ELEMENT .......',I5,/,
     2 'NUMBER OF D.O.F. ON FLUX SEGMENT ...',I5,/,
     3 'NUMBER OF D.O.F. IN TOTAL SYSTEM ...',I5)
      IF ( NHOMO .EQ. 1 )  WRITE (6,*)
     1    'NODAL POINT PROPERTIES ARE HOMOGENEOUS.'
      IF ( LHOMO .EQ. 1 )  WRITE (6,*)
     1    'ELEMENT PROPERTIES ARE HOMOGENEOUS.'
      NSUM = NTAPE1 + NTAPE2 + NTAPE3 + NTAPE4 + NTAPE5
      IF ( NSUM .GT. 0 )  
     1     WRITE (6,5180) NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5
 5180 FORMAT ( /, 'OPTIONAL UNIT NUMBERS (UTILIZED IF > 0)',/,
     1 'NTAPE1 = ',I2,', NTAPE2 = ',I2,/,'NTAPE3 = ',I2,
     2 ', NTAPE4 = ',I2,', NTAPE5 = ',I2)
      IF ( NPTWRT .EQ. 0 )  WRITE (6,*)
     1    'NODAL PARAMETERS TO BE LISTED BY NODES'
      IF ( LEMWRT .EQ. 0 )  WRITE (6,*)
     1    'NODAL PARAMETERS TO BE LISTED BY ELEMENTS'
      IF ( NULCOL .NE. 0 )  WRITE (6,*)
     1    'ALL ELEMENT COLUMN MATRICES ARE ZERO.'
      ENDIF
C      ZERO SYSTEM SOURCE VECTOR
      CALL  ZEROA (NDFREE, CC)
C-->    SET OR READ ELEMENT TYPE DATA
      CALL  INLTYP  (NLTYPE, LTDATA, N, NQP, NGEOM, NPARM, LSHAPE)
C-->    *** READ NODAL PARAMETER CONSTRAINT EQUATIONS ***
      IF ( IBUG .GT. 0 )  THEN
C       LOC = 0
C       CALL SIZEI (LOC, NEXTI, INAME, JIARAY)
C       CALL SIZER (LOC, NEXTR, RNAME, JRARAY)
        LOC1 = 0
        LOC2 = 0
        CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, I)
        CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, R)
      ENDIF
      CALL INCEQ (NG, MAXACT, NUMCE, NREQ, CEQ, NDXC, M)
      IF ( MODE .EQ. 1 )  THEN
C        DETERMINE SYSTEM HALF-BANDWIDTH
        CALL SYSBAN (NE, N, NG, IBW, NODES, LNODE, LID)
        JBW = 1
        IF ( MAXACT.GT.1 )  
     1       CALL  CEQBAN (JBW, NREQ, MAXACT, NUMCE, NDXC, NDFREE)
        MAXBAN = MAX0 ( JBW,IBW )
        WRITE (6,5110)  IBW, LID, JBW, MAXBAN
 5110   FORMAT ( /,
     1  'EQUATION HALF BANDWIDTH ............',I5,/,
     2  'OCCURS IN ELEMENT NUMBER . .........',I5,/,
     3  'CONSTRAINT HALF BANDWIDTH ..........',I5,/,
     4  'MAXIMUM HALF BANDWIDTH OF SYSTEM ...',I5)
        NCOEFF = NDFREE*MAXBAN
      ELSE
C       SKYLINE
C       CALL   SYSSKY (NDFREE, NE, N, NG, NELFRE, NODES, 
C    1                 LNODE, INDEX, LHIGH, IDIAG )
C       IF ( MAXACT.GT.1 )  
C    1       CALL  CEQSKY (IDIAG, NREQ, MAXACT, NUMCE, NDXC, NDFREE)
C       NCOEFF = IDIAG(NDFREE)
      ENDIF
        WRITE (6,5111)  NDFREE, NCOEFF
 5111   FORMAT (
     1  'TOTAL NUMBER OF SYSTEM EQUATIONS ...',I5,/,
     2  'NUMBER OF STIFFNESS COEFFICIENTS ...',I5)
C                      COMPLETE POINTERS
      LASTR = LASTR + NCOEFF
 10   WRITE (6,5120) LASTR, MAXR, LASTI, MAXI 
 5120 FORMAT ( /, '*** ARRAY STORAGE ***',/,
     1 'TYPE    REQUIRED  AVAILABLE',/,
     2 'REAL   ', 2X, I5, 2X, I5,/,
     3 'INTEGER', 2X, I5, 2X, I5)
C
C           CHECK DATA AGAINST DIMENSION STATEMENTS
      IF ( LASTR .GT. MAXR .OR. LASTI .GT. MAXI )  THEN
        WRITE (6,*) 'ERROR: IN DRIVER SET MAXR > ', LASTR
        WRITE (6,*) 'ERROR: IN DRIVER SET MAXI > ', LASTI
        STOP 'STORAGE EXCEEDED IN DRIVER, ABNORMAL PROGRAM END'
      ENDIF
C           ZERO THE SYSTEM SQUARE MATRIX
      CALL ZEROA (NCOEFF, SS)
C
C-->                 *** READ PROPERTIES ***
      IF ( IPTEST .GT. 0 )  THEN
        CALL  INPROP (M, NE, NNPFIX, NNPFLO, NLPFIX, NLPFLO, 
     1                MISCFX, MISCFL, FLTNP, FLTEL, FLTMIS, 
     2                NPFIX, LPFIX, MISFIX, NHOMO, LHOMO, 
     3                NBSFIX, NBSFLO, NBSPFX, FLTBS, NSEG)
      ELSE
        WRITE (6,*) 'WARNING, NO PROPERTY INPUT'
      ENDIF
      IF ( IBUG .GT. 0 )  THEN
        LOC1 = 0
        LOC2 = 0
        CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, I)
        CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, R)
      ENDIF
C
C-->           ** INPUT INITIAL FORCING VECTOR **
      IF ( INRHS .GT. 0 ) CALL INVECT (NDFREE, NG, CC, M, D)
C
C-->   ** READ FLUX BOUNDARY SOURCES & ADD TO SYSTEM EQS **
      IF ( NSEG .GT. 0 ) 
     1     CALL  INFLUX (NSEG, LBN, LNODE, FLUX, NG, COORD, 
     2                   NSPACE, X, M, INDEX, C, CC, NDFREE, 
     3                   S, SS, NCOEFF, NFLUX, MODE, N, IOPT,
     4                   NQP, NPARM, H, DGH, PT, WT, XYZ, DLH, 
     5                   G, DLG, AJ, AJINV, LHOMO, NBSFIX, 
     6                   NBSFLO, NBSPFX, FLTBS, GPT, GWT, NGF )
C         INITIALIZE SYSTEM DOF FOR ITERATIVE SOLUTION
      IF ( NITER .GT. 1 ) 
     1     CALL  DSTART (1, M, NG, NSPACE, NDFREE, INDEX, X, 
     2                   COORD, DDOLD)
      IF ( IBUG .GT. 0 )  THEN
        LOC1 = 0
        LOC2 = 0
        CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, I)
        CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, R)
      ENDIF
C                   *** BEGIN ITERATION LOOP ***
      RATIO = 1.0
      DO 30  IT = 1, NITER
C
C-->    *** CALCULATE AND ASSEMBLE ELEMENT MATRICES ***
C-->    *** GENERATE POST SOLUTION MATRICES & STORE ***
C
      CALL  ASYMBL ( NG, NCOEFF, MODE, IDIAG, NODES, SS, 
     1    CC, M, NE, NDFREE, NITER, LPTEST, LHOMO, 
     2    NHOMO, NULCOL, N, NSPACE, NELFRE, NRB, NQP, NGEOM,
     3    NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 
     4    LNODE, INDEX, X, DDOLD, COORD, S, C, H, DGH, B, E, EB, 
     5    STRAIN, STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     6    AJ, AJINV, HINTG, D, PRTLPT, FLTNP, FLTEL, FLTMIS,
     7    ELPROP, PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, LPPROP, 
     8    NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5,
     9    LTYPE, NLTYPE, LTDATA, LSHAPE, GPT, GWT ) 
C
C            *** ASSEMBLY COMPLETED, CHECK SOURCES ***
      IF ( NULCOL .EQ. 0 )  CALL SUMIN  (NDFREE, M, NG, CC, D)
C
C              ** SAVE DATA FOR REACTION RECOVERY **
      IF ( IT .GT. 1 .AND. NREACT .GT. 0 )  REWIND (NREACT) 
      IF ( MODE .EQ. 1 )  THEN
C        BANDED MODE
        CALL  SAVBAN (NREACT, M, NDFREE, NG, MAXBAN, IBC,
     1                INDEX, KODES, SS, CC)
      ELSE
C        SKYLINE MODE
C       CALL  SAVSKY (NREACT, M, NDFREE, NG, NCOEFF, IBC,
C    1                INDEX, KODES, SS, CC, IDIAG)
      ENDIF
C
C-->  ** APPLY BOUNDARY CONSTRAINTS TO NODAL PARAMETERS **
      CALL  APLYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 
     1              NDFREE, NCOEFF, SS, CC, IBW, IDIAG, MODE )
C
C                 ** CHECK OR FIX SQUARE MATRIX **
      IF ( MODE .EQ. 1 )  THEN
C        BANDED MODE
        CALL  BANCHK (NDFREE, MAXBAN, M, NG, SS, CC)
      ELSE
C        SKYLINE MODE
C       CALL  SKYCHK (NDFREE, NCOEFF, M, NG, SS, CC, IDIAG)
      ENDIF
C
C-->      *** SOLVE FOR UNKNOWN NODAL PARAMETERS ***
      IF ( MODE .EQ. 1 )  THEN
C        BANDED MODE
        MAXBAN = NCOEFF/NDFREE
        CALL  FACTOR (NDFREE, MAXBAN, SS)
        CALL  SOLVE  (NDFREE, MAXBAN, SS, CC, DD)
      ELSE
C       SKYLINE MODE
        FACT = .TRUE.
        BACK = .TRUE.
C       CALL  SKYSOLVE (SS, CC, DD, IDIAG, NDFREE, FACT, BACK, 
C    1                  NCOEFF)
      ENDIF
C     
C-->       *** SOLUTION COMPLETE, GET REACTIONS ***
C
      IF ( NREACT .GT. 0 ) 
     1     CALL  REACTS (NREACT, NDFREE, NG, DD, D)
C              *** PRINT RESULTS ***
      CALL  MAXMIN (M, NG, NDFREE, 1, RANGE, DD, INDEX, NRANGE)
      IF ( NPTWRT .EQ. 0 )  
     1     CALL  WRTPT (M, NG, NDFREE, NSPACE, X, DD, INDEX)
      IF ( LEMWRT .EQ. 0 ) 
     1     CALL WRTELM (NE, N, NG, NDFREE, NELFRE, DD, INDEX, 
     2                  NODES, LNODE)
C
C-->           *** POST SOLUTION CALCULATIONS ***
C
      IF ( NTAPE1 .GT. 0 )  
     1  CALL  POST ( M, NE, NG, NDFREE, NODES, LNODE, INDEX, 
     1    DD, N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, 
     2    NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, C, H, 
     3    DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, PT, WT, 
     4    XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, 
     5    ELPROP, PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, 
     6    NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER,
     7    LTYPE, NLTYPE, LTDATA, GPT, GWT, LHOMO, FLTNP, FLTEL,
     8    NPFIX, LPFIX, USEREL, USERPT, AVE, IADD )
      IF ( NITER .GT. 1 )  THEN
        IF ( IT .EQ. 1 )  RTEST = RATIO
C
C        *** UPDATE VALUES FOR NEXT ITERATION (IF ANY) ***
        WRITE (6,*)  ' '
        WRITE (6,*)  'ITERATION NUMBER = ', IT
        CALL  CHANGE (NDFREE, DD, DDOLD, TOTAL, DIFF, RATIO, 1)
        IF ( (RATIO/RTEST) .LT. CUTOFF ) GO TO 35
          CALL  CORECT (NDFREE, DD, DDOLD)
          CALL  ZEROA  (NCOEFF, SS)
          CALL  ZEROA  (NDFREE, CC)
      ENDIF
 30   CONTINUE
 35   IF ( NCURVE .GT. 0 )  THEN
C
C        ** CALCULATE CONTOUR CURVES FOR NODAL PARAMETERS **
C       CALL  CONTUR (M, NE, N, NG, NSPACE, NDFREE, NELFRE, NCURVE, 
C    1                X, COORD, XYZ, DD, D, RANGE, NODES, LNODE, INDEX)
      ENDIF
C
C                 ** BAR CHART OF SOULTION **
      IBAR   = 1
      NODIST = 0
      NDUMMY = 0
      DO 40  IPARM = 1, NG
        CALL  BARPRT (M, NDFREE, NG, NSPACE, IBAR, IPARM, NODIST, X, 
     1                DD, NDUMMY)
 40   CONTINUE
C                  *** PROBLEM COMPLETED ***
      WRITE (6,*) 'NORMAL ENDING OF MODEL PROGRAM.'
      RETURN
      END
      SUBROUTINE  MODFUL (NTOTAL, N, VALUE, S, C)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY AN ESSENTIAL B.C. TO FULL SYMMETRIC EQS
C          S*D = C,  D(N) = VALUE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  S(NTOTAL,NTOTAL), C(NTOTAL)
C     C      = FULL COLUMN MATRIX
C     N      = DOF NUMBER OF CONSTRAINED PARAMETER
C     NTOTAL = TOTAL NUMBER OF EQUATIONS
C     S      = FULL SQUARE MATRIX
C     VALUE  = GIVEN VALUE OF DOF NUMBER N
C     NOTE:    REACTION DATA ARE LOST
      DO 10  I = 1, NTOTAL
        C(I) = C(I) - VALUE*S(I,N)
        S(I,N) = 0.0
 10   S(N,I) = 0.0
      S(N,N) = 1.0
      C(N) = VALUE
      RETURN
      END
      SUBROUTINE  MODFY1 (NDFREE, MBW, L1, C1, SS, CC)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY TYPE 1 CONSTRAINT EQUATION MODIFICATIONS
C           IN UPPER HALF BANDWIDTH MODE
C               SS*DD = CC,  DD(L1) = C1
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  SS(NDFREE,MBW), CC(NDFREE)
C     SS     = RECTANGULAR MATRIX WITH UPPER HALF 
C              BANDWIDTH OF SYMMETRIC SYSTEM EQUATIONS
C     CC     = SYSTEM COLUMN MATRIX
C     L1     = SPECIFIED SYSTEM DEGREE OF FREEDOM NUMBER
C     C1     = SPECIFIED CONSTRAINT EQUATION COEFFICIENT
C     MBW    = MAX. HALF BANDWIDTH OF SYSTEM
C     NDFREE = TOTAL DEGREES OF FREEDOM OF SYSTEM
      PARAMETER  ( ZERO = 0.0 )
      M1 = MIN0 (L1,MBW) - 1
      IF ( M1 .GT. 0 )  THEN    
        DO 10  I = 1,M1
          IROW = L1 - I
          ICOL = I + 1
          IF ( C1 .NE. ZERO )  THEN
            CC(IROW) = CC(IROW) - C1*SS(IROW,ICOL)
          ENDIF
 10     SS(IROW,ICOL) = ZERO
      ENDIF
      M1 = MIN0 ( (NDFREE + 1 - L1),MBW )
      DO 20  I = 1,M1
        IROW = L1 - 1 + I
        ICOL = I
        IF ( C1 .NE. ZERO )  THEN
          CC(IROW) = CC(IROW) - C1*SS(L1,ICOL)
        ENDIF
 20   SS(L1,ICOL) = ZERO
      SS(L1,1) = 1.0
      CC(L1) = C1
      RETURN
      END
      SUBROUTINE  MODFY2 (NDFREE,MBW,IBW,L1,L2,C1,C2,S,C)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        APPLY TYPE 2 CONSTRAINT MODIFICATIONS
C            IN UPPER HALF BANDWIDTH MODE
C        D(L1) + C1*D(L2) = C2   , S*D = C
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( ZERO = 0.0 )
      DIMENSION S(NDFREE,MBW), C(NDFREE)
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     IBW    = ORIG. HALF BAND
C     MBW    = MODIFIED HALF BAND
C     L1,L2  = SPECIFIED D.O.F. NUMBERS
C     C1,C2  = CONSTRAINT EQ COEFFS
C     S      = SYS. EQ. SQ. MATRIX
C     C      = SYS. EQ. COL. MATRIX
C     D      = SYSTEM ARRAY OF DEGREES OF FREEDOM
c     write (6,*) NDFREE,MBW,IBW,L1,L2,C1,C2
C      INITIAL CALCULATIONS
      CALL  BANSUB (L1,L2,IB1,JB2)
      S12   = S(IB1,JB2)
      C11   = C(IB1)
      IROW1 = MAX0 (1,(L1-IBW+1))
      IROW2 = MIN0 (NDFREE,(L1+IBW-1))
C     SUBTRACT C1*COLUMN L1 FROM COLUMN L2
C     SUBTRACT C2*COLUMN L1 FROM R.H.S.
      DO 10  I1 = IROW1, IROW2
        CALL  BANSUB (I1,L1,IB1,JB1)
        CALL  BANSUB (I1,L2,IB2,JB2)
        S(IB2,JB2) = S(IB2,JB2) - C1*S(IB1,JB1)
        IF ( C2 .NE. ZERO )  THEN
          C(IB2) = C(IB2) - C2*S(IB1,JB1)
        ENDIF
 10   S(IB1,JB1) = ZERO
C     SUBTRACT C1*ROW L1 FROM ROW L2
C     ADD CONSTRAINT EQUATIONS
      S(L1,1) = 1.0
      S(L2,1) = S(L2,1) - C1*S12 + C1*C1
      C(L1)   = C2
      C(L2)   = C(L2) - C1*C11 + C1*C2
      CALL  BANSUB (L1,L2,IB1,JB2)
      S(IB1,JB2) = C1
C      UPON EXIT CONSTRAINT HAS INCREASED BANDWIDTH
      IBW = IBW + IABS( L2 - L1 )
c     write (6,*) NDFREE,MBW,IBW,L1,L2,C1,C2
c     IF ( IBW .GT. MBW )  STOP ' FATAL ERROR IN MODFY2'
      RETURN
      END
      SUBROUTINE  MODFY3 (NDFREE,MBW,IBW,L1,L2,L3,C1,
     1                    C2,C3,S,C)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        APPLY TYPE 3 CONSTRAINT MODIFICATIONS
C          IN UPPER HALF BANDWIDTH MODE
C        D(L1) + C1*D(L2) + C2*D(L3) = C3       ,S*D=C
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  S(NDFREE,MBW), C(NDFREE)
C     NDFREE = TOTAL NO OF SYSTEM DEGREES OF FREEDOM
C     IBW = ORIG HALF BAND, MBW = MODIFIED HALF BAND
C     L1,L2,L3 = SPECIFIED DOF NUMBERS
C     C1,C2,C3 = CONSTRAINT EQ COEFFS
C     S  = SYS EQ SQ MATRIX,  C  = SYS EQ COL MATRIX
C     D  = SYSTEM ARRAY OF DEGREES OF FREEDOM
      ZERO = 0.0
C     INITIAL CALCULATIONS
      CALL  BANSUB (L1,L2,I1,I2)
      CALL  BANSUB (L1,L3,J1,J3)
      CALL  BANSUB (L2,L3,K2,K3)
      S22 = S(L1,1)*C1*C1+C1*C1+S(L2,1)-2.*C1*S(I1,I2)
      S23 = S(K2,K3)-C2*S(I1,I2)-C1*S(J1,J3)+C1*C2*S(L1,1)+C1*C2
      S33 = S(L3,1)-2.*C2*S(J1,J3)+C2*C2*S(L1,1)+C2*C2
      C22 = C(L2)-C3*S(I1,I2)-C1*C(L1)+C1*C3*(1.+S(L1,1))
      C33 = C(L3)-C3*S(J1,J3)-C2*C(L1)+C2*C3*(1.+S(L1,1))
      IF ( S22.LE.0.0 .OR. S33.LE.0.0 ) WRITE (NBUG,5)
 5    FORMAT (' WARNING: ZERO DIAGONAL IN MODFY3')
      IROW1 = MAX0 (1,(L1-IBW+1))
      IROW2 = MIN0 (NDFREE,(L1+IBW-1))
C     SUBTRACT C1*COLUMN L1 FROM COLUMN L2
C     SUBTRACT C2*COLUMN L1 FROM COLUMN L3
C     SUBTRACT C3*COLUMN L1 FROM R.H.S.
      DO 10  K = IROW1,IROW2
      CALL  BANSUB (K,L1,I1,J1)
      CALL  BANSUB (K,L2,I2,J2)
      CALL  BANSUB (K,L3,I3,J3)
      C(I2) = C(I2) - C3*S(I1,J1)
      S(I2,J2) = S(I2,J2) - C1*S(I1,J1)
      S(I3,J3) = S(I3,J3) - C2*S(I1,J1)
 10   S(I1,J1) = ZERO
C     ADD CONSTRAINT EQUATIONS
      C(L1) = C3
      C(L2) = C22
      C(L3) = C33
      S(L1,1) = 1.0
      S(L2,1) = S22
      S(L3,1) = S33
      CALL BANSUB(L1,L2,I1,J2)
      S(I1,J2) = C1
      CALL BANSUB(L1,L3,I1,J3)
      S(I1,J3) = C2
      CALL BANSUB(L2,L3,I2,J3)
      S(I2,J3) = S23
C     UPON EXIT CONSTRAINT HAS INCREASED BANDWIDTH
      MIN = MIN0 (L1,L2,L3)
      MAX = MAX0 (L1,L2,L3)
      IBW = IBW + MAX - MIN
      IF ( IBW .GT. MBW ) STOP ' FATAL ERROR IN MODFY3'
      RETURN
      END
      SUBROUTINE  MODLFL (NDFREE, S, C, NCD, NDX, A)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY LINEAR CONSTRAINTS TO FULL SYMMETRIC EQUATIONS
C                 S*D = C  WITH CONSTRAINT
C     D(NDX(1))+A(1)*D(NDX(2))+...A(NCD-1)*D(NDX(NCD))=A(NCD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( ZERO = 0.0, ONE = 1.0 )
      DIMENSION  S(NDFREE,NDFREE), C(NDFREE), NDX(NCD), A(NCD)
C     NCD    = TOTAL NUMBER OF DOF IN CONSTRAINT EQUATION
C     NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM
C     NDX(I) = SYS DOF NOS OF CONSTRAINT TERM I
C     NR     = REDUNDANT DEGREE OF FREEDOM = NDX(1)
C     A(J)   = NORMALIZED COEFF OF (J+1) TERM, A0 = 1.0
C     C = SYSTEM COLUMN MATRIX  : Sii Sir Sid : :Di: :Ci:
C     S = SYSTEM SQUARE MATRIX  : Sri Srr Srd : :Dr:=:Cr:
C     r-redundant, d-dependent  : Sdi Sdr Sdd : :Dd: :Cd:
      E     = A(NCD)
      NR    = NDX(1)
      SRR   = S(NR,NR)
      SRRP1 = SRR + ONE
      CR    = C(NR)
      ESC   = E*SRRP1 - CR
C      FORM MODIFIED COLUMN MATRIX, Cx = Cx - E*Sxr
      IF ( E .NE. ZERO )  THEN    
        DO 10  I = 1,NDFREE
   10   C(I) = C(I) - E*S(I,NR)
      ENDIF
C      ADDITIONAL COLUMN CHANGES FOR Cd AND Cr
      IF ( NCD .GT. 1 .AND. ESC .NE. ZERO )  THEN    
        DO 30  K = 2,NCD
   30   C( NDX(K) ) = C( NDX(K) ) + A(K-1)*ESC
      ENDIF
      C(NR) = E
C        *** SQUARE MATRIX COLUMN MODIFICATIONS ***
      IF ( NCD .GT. 1 )  THEN
C      FORM Sid,  BEGIN Sdd
        DO 60  K = 2,NCD
          J = NDX(K)
          DO 50  I = 1,NDFREE
   50     S(I,J) = S(I,J) - S(I,NR)*A(K-1)
   60   CONTINUE
C      COMPLETE Sdd
        DO 80  K = 2,NCD
          I = NDX(K)
          DO 70  L = 2,NCD
            J = NDX(L)
   70     S(I,J) = S(I,J) + SRRP1*A(K-1)*A(L-1) - A(K-1)*S(J,NR)
   80   CONTINUE
C      ROW OPERATIONS
        DO 85  K = 2,NCD
          I = NDX(K)
          DO 75 L = 2,NCD
            J = NDX(L)
   75     S(J,I) = S(I,J)
   85   CONTINUE
        DO 65  K = 2,NCD
          J = NDX(K)
          DO 55  I = 1,NDFREE
   55     S(J,I) = S(I,J) 
   65   CONTINUE
      ENDIF
C            *** INSERT CONSTRAINT EQUATION ***
C     WARNING: NEXT LOOP NOT VALID FOR COUPLED LINEAR CONSTRAINTS
      DO 90  I = 1,NDFREE
        S(I,NR) = ZERO
   90 S(NR,I) = ZERO
      S(NR,NR) = 1.0
      IF ( NCD .GT. 1 )  THEN
        DO 100  K = 2,NCD
          I = NDX(K)
          S(I,NR) = A(K-1)
  100   S(NR,I) = A(K-1)
C       *** MODIFICATIONS COMPLETED, CHECK DIAGONAL ***
        DO 110  K = 2,NCD
          I = NDX(K)
          IF ( S(I,I) .LE. ZERO )  WRITE (6,*) 
     1      'Negative diagonal for constraint set', NDX
  110   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE  MSMULT (S, A, M, N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     MULTIPLY A MATRIX BY A SCALAR, AS(M,N) = S*A(M,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(1)
      MN = M*N
      DO 10  I = 1,MN
 10   A(I) = A(I)*S
      RETURN
      END
      SUBROUTINE  MTMULT (ALM, BLN, CMN, L, M, N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     TRANPOSE MATRIX MULTIPLICATION
C        C(M,N) = (A(L,M))T*B(L,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER ( ZERO = 0.0 )
      DIMENSION  ALM(L,M), BLN(L,N), CMN(M,N)
      DO 30  I = 1,N
        DO 20  J = 1,M
          SUM = ZERO
          DO 10  K = 1,L
            BLNKI = BLN(K,I)
            IF ( BLNKI.EQ.ZERO )  GO TO 10
              ALMKJ = ALM(K,J)
              IF ( ALMKJ.EQ.ZERO )  GO TO 10
                SUM = SUM + ALMKJ*BLNKI
 10       CONTINUE
          CMN(J,I) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  NGRAND (WT, DET, H, DGH, XPT, N, NSPACE, 
     1                    NELFRE, COL, SQ, NTAPE1)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C         PROBLEM DEPENDENT INTEGRAND EVALUATION IN
C         AN ISOPARAMETRIC OR SUBPARAMETRIC ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION COL(NELFRE), SQ(NELFRE,NELFRE),
     1          H(N), DGH(NSPACE,N), XPT(NSPACE)
C     N      = NUMBER OF NODES PER ELEMENT
C     NSPACE = NUMBER OF SPATIAL DIMENSIONS
C     NELFRE = NUMBER OF ELEMENT DEGREES OF FREEDOM
C     H      = ELEMENT INTERPOLATION FUNCTIONS
C     DGH    = GLOBAL DERIVATIVES OF H
C     XPT    = GLOBAL COORDS OF THE POINT
C     WT     = QUADRATURE WEIGHT AT POINT
C     DET    = JACOBIAN DETERMINATE AT POINT
C     COL    = PROB DEP COLUMN MATRIX INTEGRAND
C     SQ     = PROB DEP SQUARE MATRIX INTEGRAND
C     NTAPE1 = STORAGE UNIT FOR POST SOLUTION DATA
C     ....................................................
C     *** NGRAND PROBLEM DEPENDENT STATEMENTS FOLLOW ***
C     ....................................................
      RETURN
      END
C     ...................... NOTATION ......................
C
C     AD    = VECTOR CONTAINING FLOATING POINT VARIABLES
C     AJ    = JACOBIAN MATRIX
C     AJINV = INVERSE JACOBIAN MATRIX
C
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C
C     C      = ELEMENT COLUMN MATRIX
C     CB     = BOUNDARY SEGMENT COLUMN MATRIX
C     CC     = COLUMN MATRIX OF SYSTEM EQUATIONS
C     CEQ    = CONSTRAINT EQS COEFFS ARRAY
C     COORD  = SPATIAL COORDINATES OF A SELECTED SET OF NODES
C     CP     = PENALTY CONSTRAINT COLUMN MATRIX
C     CUTOFF = NUMBER FOR CUTTING OFF ITERATIONS
C
C     D     = NODAL PARAMETERS ASSOCIATED WITH A GIVEN ELEMENT
C     DD    = SYSTEM LIST OF NODAL PARAMETERS
C     DGH   = GLOBAL DERIV.S OF INTERPOLATION FUNCTIONS H
C     DDOLD = SYSTEM LIST OF NODAL DOF FROM LAST ITERATION
C     DLG   = LOCAL DERIVATIVES OF GEOMETRY FUNCTIONS G
C     DLH   = LOCAL DERIVATIVES OF INTERPOLATION FUNCTIONS H
C
C     E      = CONSTITUTIVE MATRIX
C     EB     = PRODUCT OF E AND B
C     ELPROP = ELEMENT ARRAY OF FLOATING POINT PROPERTIES
C
C     FLTNP  = REAL PROPERTIES OF SYSTEM NODES
C     FLTEL  = SYSTEM STORAGE OF FLOATING PT ELEMENT PROP
C     FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC. PROP
C     FLTNP  = SYSTEM STORAGE OF FLOATING PT NODAL PROP
C     FLUX   = SPATIAL COMPONENTS OF SPECIFIED BOUNDARY FLUX
C
C     G      = INTERPOLATION FUNCTIONS FOR GEOMETRY
C     GLOBAL = GLOBAL DERIV.S OF INTERPOLATION FUNCTIONS H
C
C     H      = INTERPOLATION FUNCTIONS FOR AN ELEMENT SOLUTION
C     HINTG  = INTEGRAL OF INTERPOLATION FUNCTIONS
C
C     IBC    = NODAL POINT BOUNDARY RESTRAINT INDICATOR ARRAY
C     ID     = VECTOR CONTAINING FIXED POINT ARRAYS
C     IDIAG   = DIAGONAL LOCATION IN SKYLINE VECTOR
C     INDEX  = SYSTEM DEGREE OF FREEDOM NUMBERS ARRAY
C     INRHS  > 0, IF INITIAL VALUES OF CC ARE INPUT
C     IPTEST > 0, IF SOME PROPERTIES ARE DEFINED
C     ISAY   = NO. OF USER REMARKS TO BE I/O
C
C     KFIXED = ALLOCATED SIZE OF ARRAY ID
C     KFLOAT = ALLOCATED SIZE OF ARRAY AD
C     KODES  = LIST OF DOF RESTRAINT INDICATORS AT A NODE
C     K1-K5  = NO. OF COLUMNS OF FLOATING PT CONSTRAINT DATA
C
C     LBN    = NUMBER OF NODES ON AN ELEMENT BOUNDARY SEGMENT
C     LEMWRT = 0, IF LIST NODAL PARAMETERS BY ELEMENTS
C     LHOMO  = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS
C     LNODE  = THE N ELEMENT INCIDENCES OF THE ELEMENT
C     LPFIX  = SYSTEM STORAGE ARRAY FOR FIXED PT ELEMENT PROP
C     LPROP  = ARRAY OF FIXED POINT ELEMENT PROPERTIES
C     LPTEST > 0, IF ELEMENT PROPERTIES ARE DEFINED
C
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER ELEMENT PROPERTIES
C     LPTEST  > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED
C     M      = NUMBER OF SYSTEM NODES
C     MAXACT = NO ACTIVE CONSTRAINT TYPES (<=MAXTYP)
C     MAXBAN = MAX. HALF BANDWIDTH OF SYSTEM EQUATIONS
C     MAXTIM > 0, CALCULATE CPU TIMES OF MAJOR SEGMENTS
C     MAXTYP = MAX NODAL CONSTRAINT TYPE (=3 NOW)
C     MISCFL = NO. MISC. FLOATING POINT SYSTEM PROPERTIES
C     MISCFX = NO. MISC. FIXED  POINT SYSTEM PROPERTIES
C     MISFIX = SYSTEM ARRAY OF MISC. FIXED POINT PROPERTIES
C     MODE    = MODE OF STORAGE, 0-SKYLINE, 1-BANDED
C     MTOTAL = REQUIRED SIZE OF ARRAY AD
C     M1 TO MNEXT = POINTERS FOR FLOATING POINT ARRAYS
C
C     N      = NUMBER OF NODES PER ELEMENT
C     NCURVE = NO. CONTOUR CURVES CALCULATED PER PARAMETER
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NDXC   = CONSTRAINT EQS DOF NUMBERS ARRAY
C     NE     = NUMBER OF ELEMENTS IN SYSTEM
C     NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NG     = NUMBER OF NODAL PARAMETERS (DOF) PER NODE
C     NGEOM  = NUMBER OF GEOMETRY NODES
C     NHOMO  > 0, IF NODAL SYSTEM PROPERTIES ARE HOMOGENEOUS
C     NITER  = NO. OF ITERATIONS TO BE RUN
C     NLPFIX = NO.   FIXED  POINT ELEMENT PROPERTIES
C     NLPFLO = NO. FLOATING POINT ELEMENT PROPERTIES
C     NMAT   = NUMBER OF MATERIAL TYPES
C     NNPFIX = NO. FIXED POINT NODAL PROPERTIES
C     NNPFLO = NO. FLOATING POINT NODAL PROPERTIES
C     NOCOEF = NO COEFF IN SYSTEM SQ MATRIX
C     NODES  = ELEMENT INCIDENCES OF ALL ELEMENTS
C     NOTHER = TOTAL NO. OF BOUNDARY RESTRAINTS .GT. TYPE1
C     NPARM  = DIMENSION OF PARAMWETRIC SPACE
C     NPFIX  = INTEGER PROPERTIES AT ALL NODES
C     NPROP  = NODAL ARRAY OF FIXED POINT PROPERTIES
C     NPTWRT = 0, LIST NODAL PARAMETERS BY NODES
C     NQP    = NUMBER OF QUADRATURE POINTS
C     NRANGE = ARRAY CONTAINING NODE NO.S OF EXTREME VALUES
C     NRB    = NUMBER OF ROWS IN B AND E MATRICES
C     NREQ   = NO. OF CONSTRAINT EQS. OF EACH TYPE
C     NRES   = NO. OF CONSTRAINT FLAGS OF EACH TYPE
C     NSEG   = NO OF ELEM BOUNDARY SEGMENTS WITH GIVEN FLUX
C     NSPACE = DIMENSION OF SPACE
C     NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     NTOTAL = REQUIRED SIZE OF ARRAY ID
C     NULCOL > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO
C     NUMCE  = NUMBER OF CONSTRAINT EQS
C     N1 TO NNEXT = POINTERS FOR FIXED POINT ARRAYS
C
C     PTPROP = NODAL ARRAY OF FLOATING PT PROPERTIES
C     PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT     = QUADRATURE COORDINATES
C     PRTLPT = FLOATING PT PROP ARRAY OF ELEMENT'S NODES
C
C     RANGE: 1-MAXIMUM VALUE, 2-MINIMUM VALUE OF DOF
C
C     S      = ELEMENT SQUARE MATRIX
C     SB     = BOUNDARY SEGMENT SQUARE MATRIX
C     SS     = 'SQUARE' MATRIX OF SYSTEM EQUATIONS
C     STRAIN = STRAIN OR GRADIENT VECTOR
C     STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS = STRESS VECTOR
C
C     TIME  = ARRAY STORING CPU TIMES FOR VARIOUS SEGMENTS
C     TITLE = PROBLEM TITLE
C
C     WT  = QUADRATURE WEIGHTS
C
C     X   = COORDINATES OF SYSTEM NODES
C     XYZ = SPACE COORDINATES AT A POINT
C     X   = SPATIAL COORDINATES OF ALL NODES IN THE SYSTEM
C     XPT = SPATIAL COORDINATES OF A CONTOUR POINT
C
C     ......................................................
      SUBROUTINE  PENLTY (NPFRE, CEQ, CP, SP, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     DEFINE CONSTRAINT PENALTY SQ AND COL MATRICES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  CEQ(NPFRE), CP(NPFRE), SP(NPFRE,NPFRE)
C     NPFRE  = NO DOF IN CONSTRAINT EQUATION
C     CEQ(I) = CONSTR EQ COEFFICIENT I+1
C     CP     = CONSTRAINT COLUMN MATRIX
C     SP     = CONSTRAINT SQUARE MATRIX
C     WT     = PENALTY WEIGHT FACTOR
C      INITIAL CALCULATIONS
      CP(1) = 1.0
      TEMP  = CEQ(NPFRE)
      IF ( NPFRE .GT. 1 )  THEN
        DO 10  I = 2,NPFRE
 10     CP(I) = CEQ(I-1)
      ENDIF
C      CALCULATE LEAST SQ CONSTRAINT FORMS
      DO 40  I = 1, NPFRE
        DO 30  J = 1, NPFRE
 30     SP(J,I) = WT*CP(I)*CP(J)
 40   CONTINUE
      DO 50  I = 1, NPFRE
 50   CP(I) = CP(I)*TEMP*WT
      RETURN
      END
      SUBROUTINE  PENMOD (MAXACT, NUMCE, NREQ, NDXC, CEQ, 
     1                    CP, SP, CC, SS, NDFREE, MAXBAN)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C       APPLY CONSTRAINT EQS BY PENALTY MODIFICATIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION SS(NDFREE,MAXBAN), CC(NDFREE), CP(MAXACT),
     1          SP(MAXACT,MAXACT), CEQ(MAXACT,NUMCE),
     2          NDXC(MAXACT,NUMCE), NREQ(MAXACT)
      DATA      FACTOR / 1.D12 /
C     MAXACT    = NUMBER OF ACTIVE CONSTRAINT TYPES
C     NUMCE     = NUMBER OF CONSTRAINT EQUATIONS
C     NREQ(I)   = NUMBER OF CONSTR EQS OF TYPE I
C     NDXC(I,J) = DOF NUMBER OF TERM I OF EQ J
C     CEQ(I,J)  = COEFF TERM I+1 OF EQ J
C     CP        = PENALTY SQUARE MATRIX
C     SP        = PENALTY SQUARE MATRIX
C     SS        = SYSTEM SQ MATRIX UPPER HALF BANDWIDTH
C     CC        = SYSTEM COLUMN MATRIX
C     FACTOR    = PENALTY WEIGHT FACTOR
      IEQ = 0
C      FIND NUNBER OF EQS OF EACH TYPE
      DO 30 IC = 1, MAXACT
        NTEST = NREQ(IC)
        IF ( NTEST .GT. 0 )  THEN
C          BEST TO CALL MODFY1 IF IC=1
          IF ( IC .GT.1  ) FACTOR = 1.0D3
C          LOOP OVER NO EQS
          DO 20 J = 1, NTEST
            IEQ = IEQ + 1
C            SELECT AVERAGE WEIGHT
            WT = 0.0
            DO 10 K = 1, IC
 10         WT = WT + SS(NDXC(K,IEQ),1)
            WT = WT*FACTOR/IC
C            EXTRACT COEFF AND FORM LEAST SQ MATRICES
            CALL PENLTY (IC,CEQ(1,IEQ),CP,SP,WT)
C            EXTRACT DOF NOS AND ADD PENALTY TO SYS EQS
            CALL STORCL (NDFREE,IC,NDXC(1,IEQ),CP,CC)
            CALL STORSQ (NDFREE,MAXBAN,IC,NDXC(1,IEQ),SP,SS)
 20       CONTINUE
        ENDIF
 30   CONTINUE
      RETURN
      END
      SUBROUTINE PLTSET (FLTMIS)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT PLOTTER PARAMETERS FROM MISC. DATA STORAGE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     REFER TO STANDARD CALCOMP MANUALS
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  FLTMIS(6)
      COMMON /PLTKAL/ XLEN, YLEN, FIRSTX, FIRSTY, DELTAX, DELTAY,
     1                XLAST, YLAST
      DATA  KALPLT / 1 /
C     XLEN, YLEN     = PLOT LENGTH IN INCHES
C     FIRSTX, FIRSTY = GLOBAL COORDINATES OF PLOT ORIGIN
C     DELTAX, DELTAY = CHANGE IN GLOBAL COORD. PER INCH OF PLOT
C      USE FIRST SIX LOCATIONS FOR PLOTTER
      XLEN   = FLTMIS(1)
      YLEN   = FLTMIS(2)
      FIRSTX = FLTMIS(3)
      FIRSTY = FLTMIS(4)
      DELTAX = FLTMIS(5)
      DELTAY = FLTMIS(6)
      XLAST  = FIRSTX + XLEN*DELTAX
      YLAST  = FIRSTY + YLEN*DELTAY
      WRITE (6,5000) XLEN, YLEN, FIRSTX, FIRSTY, DELTAX, DELTAY
 5000 FORMAT ( /, '* SUPPLIED PLOT PARAMETERS *',/,
     1'X-LENGTH...',1PE13.3,'    Y-LENGTH...',1PE13.3,/,
     2'FIRST-X....',1PE13.3,'    FIRST-Y....',1PE13.3,/,
     3'DELTA-X....',1PE13.3,'    DELTA-Y....',1PE13.3,/)
      IF ( KALPLT .EQ. 0 )  RETURN
C-->     ON THE FIRST CALL OPEN THE PLOT FILE
        KALPLT = 0
C        INSTALLATION DEPENDENT STATEMENTS FOLLOW
CPLT    CALL PLOTS (0,0,0,'MODEL')
        RETURN
      END
      SUBROUTINE  POST ( M, NE, NG, NDFREE, NODES, LNODE, INDEX, 
     1    DD, N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, 
     2    NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, C, H, 
     3    DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, PT, WT, 
     4    XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, 
     5    ELPROP, PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, 
     6    NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER,
     7    LTYPE, NLTYPE, LTDATA, GPT, GWT, LHOMO, FLTNP, FLTEL,
     8    NPFIX, LPFIX, USEREL, USERPT )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C           ELEMENT LEVEL POST-SOLUTION CALCULATIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT   REAL*8  (A-H,O-Z)
      DATA  LASTLT / 0 /
C        ALWAYS USED
      DIMENSION  COORD(N,NSPACE), S(NELFRE,NELFRE), DD(NDFREE), 
     1           D(NELFRE), NODES(NE,N), LNODE(N), INDEX(NELFRE),
     2           LTYPE(NE), LTDATA(6,NLTYPE)
C
C        USUALLY USED
      DIMENSION  C(NELFRE), H(N,0:NQP), DGH(NSPACE,N), B(NRB,NELFRE), 
     1           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     2           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE)
C
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION  PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N,0:NQP), 
     1           G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 
     2           AJINV(NSPACE,NSPACE), HINTG(N), XYZ(NSPACE),
     3           GPT(0:NQP), GWT(0:NQP)
C
C        OPTIONAL PROPERTY AND SOLUTION VALUES
      DIMENSION  D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 
     1           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     2           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     3           LPPROP(0:NNPFIX)
      DIMENSION  FLTNP(M,0:NNPFLO), FLTEL(NE,0:NLPFLO),
     1           NPFIX(M,0:NNPFIX), LPFIX(NE,0:NLPFIX)
C
C        OPTIONAL USER APPLICATION AT NODE OR ELEMENT
      DIMENSION  USERPT(NG), USEREL(NG,N)
C
C                     VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DD      = ARRAY OF SYSTEM DEGREES OF FREEDOM
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF FLOATING PT PROPERTIES
C     FLTMIS  = SYSTEM STORAGE OF FLOATING PT MISC PROP
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     INDEX   = SYSTEM DOF NOS ASSOCIATED WITH ELEMENT
C     IT      = CURRENT ITERATION NUMBER
C     LNODE   = THE N ELEMENT INCIDENCES OF THE ELEMENT
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER POINT ELEMENT PROPERTIES
C     M       = TOTAL NUMBER OF NODES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NDFREE  = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NE      = NUMBER OF ELEMENTS IN SYSTEM
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NG      = NUMBERS PARAMETERS PER NODE
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NITER   = MAX NUMBER OF ITERATIONS
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NODES   = ELEMENT INCIDENCES OF ALL ELEMENTS
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     USEREL  = (USER CHOICE) ELEMENT APPLICATION RESULT
C     USERPT  = (USER CHOICE) NODAL APPLICATION RESULT
C     WT      = QUADRATURE WEIGHTS
C     XYZ     = SPACE COORDINATES AT A POINT
C      NTAPE1 MUST BE > 0 
      IF ( NTAPE1 .GT. 0 )  THEN
        REWIND  NTAPE1
      ELSE
        STOP 'NO NTAPE1 IN POST'
      ENDIF
C
C-->   LOOP OVER ELEMENTS
      LPTEST = NLPFIX + NLPFLO
      DO 10  IE = 1, NE
C-->     GET ELEMENT TYPE NUMBER
        LT = 1
        IF ( NLTYPE .GT. 1 )  LT = LTYPE(IE) 
C        SAME AS LAST TYPE ?
        IF ( LT .NE. LASTLT )  THEN
          LASTLT = LT
C          GET CONTROLS FOR THIS TYPE
          CALL  GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM,
     1                 LTPARM, LTSHAP, LTUSER )
          LTFREE = LTN*NG
C-->       GET QUADRATURE RULE FOR ELEMENT TYPE AND SHAPE
          IF ( LTQP .GT. 0 ) CALL  GETQD (LTSHAP, LTQP, NSPACE, 
     1                                    GPT, GWT, PT, WT)
        ENDIF
C-->     EXTRACT ELEMENT NODE NUMBERS
        CALL  LNODES (IE, NE, LTN, NODES, LNODE)
C-->     CALCULATE DEGREE OF FREEDOM NUMBERS
        CALL  INDXEL (LTN, LTFREE, NG, LNODE, INDEX)
C-->     EXTRACT NODAL PARAMETERS OF THE ELEMENT
        CALL  ELFRE (NDFREE, LTFREE, D, DD, INDEX)
C-->     EXTRACT NODAL POINT PROPERTIES (IF ANY)
        IF ( NNPFLO .GT. 0 )  CALL  LPTPRT (N, M, NNPFLO, FLTNP, 
     1              PRTLPT, NNPFIX, NPFIX, LPPROP, LNODE, NHOMO)
C-->     EXTRACT ELEMENT PROPERTIES (IF ANY)
        IF ( LPTEST .GT. 0 )  CALL ELPRTY (IE, LHOMO, NE, NLPFIX, 
     1              NLPFLO, LPFIX, FLTEL, LPROP, ELPROP)
C-->     EXTRACT MATERIAL PROPERTIES (IF ANY)
        IF ( NMAT .GT. 0 )  CALL MATPRT (NMAT, NLPFLO, MISCFL, 
     1                                   FLTMIS,PRTMAT)
C
C-->     PERFORM PROBLEM DEPENDENT CALCULATIONS AND OUTPUT
C
        CALL  POSTEL (LTN, NSPACE, LTFREE, NRB, LTQP, LTGEOM,
     1    LTPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX,
     2    NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN,
     3    STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     4    AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     5    PRTMAT, MISFIX, LTSHAP, LPROP, LPPROP, NTAPE1, 
     6    NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER, IE, NE,
     7    LNODE, NG, USEREL, USERPT )
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  POSTEL (N, NSPACE, NELFRE, NRB, NQP, NGEOM,
     1    NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX,
     2    NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN,
     3    STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG,
     4    AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 
     5    PRTMAT, MISFIX, LTSHAP, LPROP, LPPROP, NTAPE1, 
     6    NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER, IE, NE, 
     7    LNODE, NG, USEREL, USERPT )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C           ELEMENT LEVEL POST-SOLUTION CALCULATIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT   REAL*8  (A-H,O-Z)
C        ALWAYS USED
      DIMENSION  COORD(N,NSPACE), S(NELFRE,NELFRE), C(NELFRE)
C
C        USUALLY USED
C     DIMENSION  H(N,0:NQP), DGH(NSPACE,N,0:NQP), B(NRB,NELFRE), 
      DIMENSION  H(N), DGH(NSPACE,N), B(NRB,NELFRE), 
     1           E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 
     2           STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE)
C
C        OPTIONAL FOR NUMERICAL INTEGRATION
      DIMENSION  PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N), 
     1           G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 
     2           AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N),
     3           XYZ(NSPACE)
C
C        OPTIONAL PROPERTY AND SOLUTION VALUES
      DIMENSION  D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 
     1           ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 
     2           MISFIX(0:MISCFX), LPROP(0:NLPFIX), 
     3           LPPROP(0:NNPFIX)
C
C        OPTIONAL USER APPLICATION AT NODE OR ELEMENT
      DIMENSION  USERPT(NG), USEREL(NG,N)
C
C                     VARIABLES:
C     AJ      = JACOBIAN
C     AJINV   = JACOBIAN INVERSE
C     B       = STRAIN-DISPLACEMENT (GRADIENT) MATRIX
C     BODY    = BODY FORCE VECTOR
C     C       = ELEMENT COLUMN MATRIX
C     COORD   = SPATIAL COORDINATES OF ELEMENT'S NODES
C     D       = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT
C     DGH     = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS
C     DLG     = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION
C     DLH     = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS
C     E       = CONSTITUTIVE MATRIX
C     EB      = PRODUCT OF E*B
C     ELPROP  = ELEMENT ARRAY OF FLOATING PT PROPERTIES
C     FLTMIS  = SYSTEM STORAGE OF FLOATING PT MISC PROP
C     G       = GEOMETRIC INTERPOLATION FUNCTIONS
C     H       = SOLUTION INTERPOLATION FUNCTIONS
C     HINTG   = INTEGRAL OF INTERPOLATION FUNCTIONS
C     IE      = CURRENT ELEMENT NUMBER
C     IT      = CURRENT ITERATION NUMBER
C     LNODE   = ELEMENT TOPOLOGY LIST
C     LPPROP  = INTEGER PROPERTIES AT EACH ELEMENT NODE
C     LPROP   = ARRAY INTEGER POINT ELEMENT PROPERTIES
C     MISFIX  = MISCELLANEOUS INTEGER SYSTEM PROPERTIES
C     N       = NUMBER OF NODES PER ELEMENT
C     NE      = TOTAL NUMBER OF ELEMENTS
C     NELFRE  = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
C     NG      = NUMBER OF GENERALIZED UNKNOWNS PER NODE
C     NGEOM   = NUMBER OF GEOMETRY NODES
C     NITER   = MAX NUMBER OF ITERATIONS
C     NMAT    = NUMBER OF MATERIAL TYPES
C     NPARM   = DIMENSION OF PARAMWETRIC SPACE
C     NQP     = NUMBER OF QUADRATURE POINTS
C     NRB     = NUMBER OF ROWS IN B AND E MATRICES
C     NSPACE  = DIMENSION OF SPACE
C     NTAPE1  = UNIT FOR POST SOLUTION MATRICES STORAGE
C     NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0)
C     PRTLPT  = REAL PROPERTIES AT ELEMENT NODES
C     PRTMAT  = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER
C     PT      = QUADRATURE COORDINATES
C     S       = ELEMENT SQUARE MATRIX
C     STRAIN  = STRAIN OR GRADIENT VECTOR
C     STRAN0  = INITIAL STRAIN OR GRADIENT VECTOR
C     STRESS  = STRESS VECTOR
C     USEREL  = (USER CHOICE) ELEMENT APPLICATION RESULT
C     USERPT  = (USER CHOICE) NODAL APPLICATION RESULT
C     WT      = QUADRATURE WEIGHTS
C     XYZ     = SPACE COORDINATES AT A POINT
C     ....................................................
C      *** POSTEL PROBLEM DEPENDENT STATEMENTS FOLLOW ***
C     ....................................................
      RETURN 
      END
      SUBROUTINE  PTCODE (JPT, NG, KODE, KODES)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT B.C. INDICATORS AT NODE NUMBER JPT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  KODES(NG)
C     JPT   = NODE NO.
C     NG    = NO. PARAMETERS PER NODE
C     KODE  = (NG) DIGIT INTEGER CONTAINING BC INDICATORS
C     KODES = VECTOR CONTAINING NG INTEGER CODES (0 OR I)
C        0  IMPLIES NO B. C.
C        I  IMPLIES A B. C.  OF TYPE I
      NGPLUS = NG + 1
      IOLD   = KODE
      ISUM   = 0
      DO 10  I = 1,NG
        II = NGPLUS - I
        INEW = IOLD/10
        IK = IOLD - INEW*10
        ISUM = ISUM + IK*10**(I-1)
        IOLD = INEW
 10   KODES(II) = IK
C      WAS DATA RIGHT JUSTIFIED?
      IF ( KODE .GT. ISUM )  WRITE (NBUG,*) 
     1  'WARNING,BC NOT RIGHT JUSTIFIED AT NODE', JPT
      RETURN
      END
      SUBROUTINE  PTCORD (IPT, M, NSPACE, X, COORD)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     EXTRACT COORDINATES OF POINT NUMBER IPT
C     * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  X(M,NSPACE), COORD(1,NSPACE)
C     X      = SPATIAL COORDINATES OF ALL SYSTEM NODES 
C     COORD  = SPATIAL COORDINATES OF THE NODE
C     M      = TOTAL NUMBER OF NODES IN SYSTEM
C     N      = NUMBER OF NODES PER ELEMENT
C     NSPACE = DIMENSION OF THE SPACE
      DO 10  J = 1, NSPACE
 10   COORD(1,J) = X(IPT,J)
      RETURN
      END
      SUBROUTINE  RADAU (N, P, W)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     RADAU QUADRATURE ABSCISSAE AND WEIGHTS FOR UNIT TRIANGLE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( NMAX = 16 )
      DIMENSION  P(2,0:N), W(0:N)
C     N      = TOTAL NUMBER OF QUADRATURE POINTS
C     P(1,I) = ABSCISSAE IN R-DIRECTION
C     P(2,I) = ABSCISSAE IN S-DIRECTION
C     W(I)   = CORRESPONDING WEIGHTS
C     NMAX   = MAXIMUM DEGREE TABULATED HEREIN
      NGP = N
      IF ( N .GT. NMAX )  THEN
          WRITE (NPRT,*) 'WARNING, RADAU N SET TO', NMAX
        NGP = NMAX
      ENDIF
      IF ( NGP .EQ. 1 )  THEN 
C        M = NGP = 1
        P(1,1) = 0.333333333333
        P(2,1) = 0.333333333333
        W(1) = 0.5
        RETURN
      ENDIF
      IF ( NGP .EQ. 4 )  THEN 
C        M = 2, NGP = M*M
        W(1) = 0.0909793091
        W(2) = 0.1590206909
        W(3) = 0.0909793091
        W(4) = 0.1590206909
        P(1,1) = 0.2800199155
        P(1,2) = 0.6663902460
        P(1,3) = 0.0750311102
        P(1,4) = 0.1785587283
        P(2,1) = 0.0750311102
        P(2,2) = 0.1785587283
        P(2,3) = 0.2800199155
        P(2,4) = 0.6663902460
        RETURN
      ENDIF
      IF ( NGP .EQ. 9 )  THEN 
C        M = 3, NGP = M*M
        W(1) = 0.019396383304
        W(2) = 0.063678085097
        W(3) = 0.055814420490
        W(4) = 0.031034213285
        W(5) = 0.101884936154
        W(6) = 0.089303072783
        W(7) = 0.019396383304
        W(8) = 0.063678085097
        W(9) = 0.055814420490
        P(1,1) = 0.18840940591
        P(1,2) = 0.52397906774
        P(1,3) = 0.80869438567
        P(1,4) = 0.10617026910
        P(1,5) = 0.29526656780
        P(1,6) = 0.45570602025
        P(1,7) = 0.02393113229
        P(1,8) = 0.06655406786
        P(1,9) = 0.10271765483
        P(2,1) = 0.02393113229
        P(2,2) = 0.06655406786
        P(2,3) = 0.10271765483
        P(2,4) = 0.10617026910
        P(2,5) = 0.29526656780
        P(2,6) = 0.45570602025
        P(2,7) = 0.18840940591
        P(2,8) = 0.52397906774
        P(2,9) = 0.80869438567
        RETURN
      ENDIF
      IF ( NGP .EQ. 16 )  THEN 
C        M = 4, NGP = M*M
        W(1) = 0.005423225910
        W(2) = 0.022584049287
        W(3) = 0.035388067900
        W(4) = 0.023568368199
        W(5) = 0.010167259561
        W(6) = 0.042339724518
        W(7) = 0.066344216093
        W(8) = 0.044185088522
        W(9) = 0.010167259561
        W(10) = 0.042339724518
        W(11) = 0.066344216093
        W(12) = 0.044185088522
        W(13) = 0.005423225910
        W(14) = 0.022584049287
        W(15) = 0.035388067900
        W(16) = 0.023568368199
        P(1,1) = 0.13005607918
        P(1,2) = 0.38749748338
        P(1,3) = 0.67294686319
        P(1,4) = 0.87742880935
        P(1,5) = 0.09363778441
        P(1,6) = 0.27899046348
        P(1,7) = 0.48450832666
        P(1,8) = 0.63173125166
        P(1,9) = 0.04612207989
        P(1,10) = 0.13741910412
        P(1,11) = 0.23864865974
        P(1,12) = 0.31116455224
        P(1,13) = 0.00970378512
        P(1,14) = 0.02891208422
        P(1,15) = 0.05021012321
        P(1,16) = 0.06546699455
        P(2,1) = 0.00970378512
        P(2,2) = 0.02891208422
        P(2,3) = 0.05021012321
        P(2,4) = 0.06546699455
        P(2,5) = 0.04612207989
        P(2,6) = 0.13741910412
        P(2,7) = 0.23864865974
        P(2,8) = 0.31116455224
        P(2,9) = 0.09363778441
        P(2,10) = 0.27899046348
        P(2,11) = 0.48450832666
        P(2,12) = 0.63173125166
        P(2,13) = 0.13005607918
        P(2,14) = 0.38749748338
        P(2,15) = 0.67294686319
        P(2,16) = 0.87742880935
      ENDIF
      RETURN
      END
      SUBROUTINE REACT (NREACT, NDFREE, NG, DD)
C     * * * * * * * * * * * * * * * * * * * * * * **
C       USE THE KNOWN SOLUTION, DD, TO COMPUTE THE
C     REACTIONS AT THE ESSENTIAL BOUNDARY CONDITIONS
C        FOR FULL SYMMETRIC EQUATIONS, SS*DD = CC
C     * * * * * * * * * * * * * * * * * * * * * * **
C     SEE SUBROUTINE SAVFUL, SAVBAN, OR SAVSKY
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DD(NDFREE)
C     DD     = COMPUTED SOLUTION VECTOR, SS*DD=CC
C     N      = DOF NUMBER OF ESSENTIAL B.C.
C     NG     = NUMBER OF DOF PER NODE
C     NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA
C     NDFREE = TOTAL NUMBER OF EQUATIONS
      REWIND  NREACT
      WRITE (6, 5000) 
 5000 FORMAT ( /, '*** REACTION RECOVERY ***', /,
     1 'EQUATION      REACTION       NODE  PARM')
C      READ EQUATION NUMBER
   10 READ (NREACT, END=30)  N
      IN = (N + NG -1)/NG
      IP = N - NG*(IN -1)
      R = 0.0
C      READ THE N-TH ROW
      DO 20  J = 1, NDFREE
        READ (NREACT)  SNJ
   20 R = R + SNJ * DD(J)
      READ (NREACT)  CN
      R = R - CN
      WRITE (6, 5010) N, R, IN, IP
 5010 FORMAT ( I6, 1PE15.5, I5, I3 )
      GO TO 10
   30 RETURN
      END
      SUBROUTINE  REACTEL (IE, N, NELFRE, NG, NTAPE1, S, C,
     1                     D, USERPT, USEREL, LNODE )
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C       GET REACTIONS (FLUXES) AT AN ELEMENTS NODES
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  S(NELFRE,NELFRE), C(NELFRE), D(NELFRE),
     1           USERPT(NG), USEREL(NG,N), LNODE(N)
C     C       = ELEMENT COLUMN MATRIX
C     D       = KNOWN SOLUTION CAUSING THE REACTIONS
C     IE      = CURRENT ELEMENT NUMBER
C     LNODE   = ELEMENT TOPOLOGY LIST
C     N       = NUMBER OF NODES PER ELEMENT
C     NELFRE  = NUMBER OF ELEMENT DOF, NG*N
C     NG      = NUMBER OF GENERALIZED UNKNOWNS PER NODE
C     NTAPE1  = UNIT TO HOLDING S & C FROM ELEMENT IE
C     S       = ELEMENT SQUARE MATRIX
C     USEREL  = (USER CHOICE) ELEMENT APPLICATION RESULT
C     USERPT  = (USER CHOICE) NODAL APPLICATION RESULT
      IF ( NTAPE1 .LT. 1 )  STOP 'INVALID UNIT IN REACTEL'
C       GIVE REACTIONS, R = S*D - C
      CALL ZEROA (NG,USERPT)
      CALL ZEROA (NG*N,USEREL)
C       WARNING: S & C MUST BE STORED WITH A SINGLE WRITE
      READ (NTAPE1)  S, C
      DO 30  IN = 1, N
        IF ( IN .EQ. 1 ) 
     1    WRITE (6,*) ' NODE IDOF    REACTION       SOURCE'
        DO 35  IG = 1, NG
          IROW = NG*(IN - 1) + IG
          USEREL(IG,1) = USEREL(IG,1) + C(IROW)
          ROW  = 0.D0
          DO 40  L = 1, NELFRE
   40       ROW = ROW + S(IROW,L)*D(L)
          REACT = ROW - C(IROW)
          USERPT(IG) = USERPT(IG) + REACT
          WRITE (6,5030)  LNODE(IN), IG, REACT, C(IROW)
 5030     FORMAT( I5, I5, 1PE15.5, 1PE15.5 )
   35     CONTINUE
   30   CONTINUE
        DO 50 IG = 1, NG
   50     WRITE (6,5050) IG, USERPT(IG), USEREL(IG,1)
 5050   FORMAT (' SUM:', I5, 1PE15.5, 1PE15.5 )
      RETURN
      END
      SUBROUTINE REACTS (NREACT, NDFREE, NG, DD, TOTAL)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C-->       COMPUTE REACTIONS IN BANDED MODE
C     * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DD(NDFREE), TOTAL(NG)
C     DD     = COMPUTED SOLUTION VECTOR, SS*DD=CC
C     N      = DOF NUMBER OF ESSENTIAL B.C.
C     NG     = NUMBER OF DOF PER NODE
C     NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA
C     NDFREE = TOTAL NUMBER OF EQUATIONS
      IF ( NREACT .GT. 0 )  THEN
        REWIND  NREACT
        WRITE (6, 5000) 
 5000   FORMAT ( /, '*** REACTION RECOVERY ***', /,
     1   'NODE  DOF  REACTION   EQUATION')
        DO 5  J = 1,NG
    5   TOTAL(J) = 0.0
      ELSE
        STOP 'NO REACTION FILE, REACTS'
      ENDIF 
C      READ NODE, PARAMETER, RANGE OF NON-ZERO TERMS
   10 READ (NREACT, END=30)  NODE, IG, J1, J2
      R = 0.0
      DO 20  J = J1, J2
        READ (NREACT)  SIJ
   20 R = R + SIJ * DD(J)
      READ (NREACT)  CI
      R  = R - CI
      IE = NG*(NODE - 1) + IG
      WRITE (6,5010) NODE, IG, R, IE
 5010 FORMAT ( 2 I4, 1X, 1PE11.4, I6 )
      TOTAL(IG) = TOTAL(IG) + R
      GO TO 10
   30 WRITE (6,5020)
 5020 FORMAT ('*RESULTANTS*',/,
     1        'DOF       SUM')
      DO 40  J = 1, NG
   40 WRITE (6,5030) J, TOTAL(J)
 5030 FORMAT ( I3, 2X, 1PE12.4 )
      RETURN
      END
      SUBROUTINE  RPRINT (A, NR, NC, IOPT)
C     * * * * * * * * * * * * * * * * * * * * * * *
C          PRINTING OF REAL MATRIX A(NR,NC)
C     * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A)
      PARAMETER ( NPRT = 6, MAX = 10 )
      DIMENSION  A(1), NCOL(MAX)
C     A    = REAL ARRAY
C     NR   = NUMBER OF ROWS IN A
C     NC   = NUMBER OF COLUMNS IN A
C     IOPT = 0 USE F FORMAT, OTHERWISE USE E FORMAT
      DO 50  J = 1, NC, MAX
        JL1 = J - 1
        MAXCOL = 1
        K = NC - JL1
        MAXCOL = MIN0 (K,MAX)
        MXCLL1 = MAXCOL - 1
        DO 10  L = 1, MAXCOL
   10   NCOL(L) = L + JL1
        WRITE (NPRT,5000)  ( NCOL(N),N=1,MAXCOL )
 5000   FORMAT ('ROW/COL', I7, 9I10 )
        DO 40  N = 1, NR
          NL = N + (J-1)*NR
          NH = NL + MXCLL1*NR
          IF ( IOPT )  30,20,30
   20       WRITE (NPRT,5010)  N,( A(I),I=NL,NH,NR )
 5010       FORMAT (I4, 8F10.4)
            GO TO 40
   30       WRITE (NPRT,5020)  N,( A(I),I=NL,NH,NR )
 5020       FORMAT (I4, 10(1PE10.2) )
   40   CONTINUE
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  SAVBAN (NREACT, M, NDFREE, NG, IBW, IBC,
     1                    INDEX, KODES, SS, CC)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C-->  SAVE INDEPENDENT REACTION EQUATIONS FROM BANDED MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  SS(NDFREE, IBW), CC(NDFREE), IBC(M),
     1           INDEX(NG), KODES(NG)
C     NG     = NUMBER OF DOF PER NODE
C     NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA
C     NDFREE = TOTAL NUMBER OF EQUATIONS
C      LOOP OVER EQUATIONS FOR ESSENTIAL BC FLAG
      DO 30  J = 1, M
        IF ( IBC(J) .GT. 0 )  THEN
          CALL  PTCODE (J, NG, IBC(J), KODES )
          CALL  INDXPT  (J, NG, INDEX)
          DO 20  IG = 1, NG
            IF ( KODES(IG) .EQ. 1 )  THEN
C              FOUND TYPE ONE BC
              INDX = INDEX(IG)
              J1 = MAX0( (INDX-IBW+1), 1 )
              J2 = MIN0( (INDX+IBW-1), NDFREE )
C              WRITE NODE, PARAMETER, RANGE OF NON-ZEROS
              WRITE (NREACT) J, IG, J1, J2
C              SAVE ROW OF EQUILIBRIUM EQ
              DO 10  JJ = J1, J2
                CALL  BANSUB (INDX, JJ, IROW, JCOL)
   10         WRITE (NREACT) SS(IROW,JCOL)
              WRITE (NREACT) CC(INDX)
            ENDIF
   20     CONTINUE
        ENDIF
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  SAVFUL (NREACT, M, NDFREE, NG, IBC,
     1                    INDEX, KODES, SS, CC)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C-->  SAVE INDEPENDENT REACTION EQUATIONS FROM FULL MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  SS(NDFREE, NDFREE), CC(NDFREE), IBC(M),
     1           INDEX(NG), KODES(NG)
C     NG     = NUMBER OF DOF PER NODE
C     NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA
C     NDFREE = TOTAL NUMBER OF EQUATIONS
C      LOOP OVER EQUATIONS FOR ESSENTIAL BC FLAG
      DO 30  J = 1, M
        IF ( IBC(J) .GT. 0 )  THEN
          CALL  PTCODE (J, NG, IBC(J), KODES )
          CALL  INDXPT  (J, NG, INDEX)
          DO 20  IG = 1, NG
            IF ( KODES(IG) .EQ. 1 )  THEN
C              FOUND TYPE ONE BC
              INDX = INDEX(IG)
              J1 = 1
              J2 = NDFREE 
C              WRITE NODE, PARAMETER, RANGE OF NON-ZEROS
              WRITE (NREACT) J, IG, J1, J2
C              SAVE ROW OF EQUILIBRIUM EQ
              DO 10  JJ = J1, J2
   10         WRITE (NREACT) SS(INDX,JJ)  
              WRITE (NREACT) CC(INDX)
            ENDIF
   20     CONTINUE
        ENDIF
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  SCHECK (H,N)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     NUMERICAL CHECKING OF N SHAPE FUNCTIONS, H, AT A
C               LOCAL POINT IN A C0 ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DOUBLE PRECISION  ONE, SUM, TOL
      PARAMETER  ( ONE = 1.0D0, TOL = 1.0D-7, NPRT = 6 )
      DIMENSION  H(N)
C     H = LOCAL COORDINATE INTERPOLATION FUNCTIONS
C     N = NUMBER OF SHAPE FUNCTIONS
      SUM = 0.0D0
      DO 10  I = 1,N
 10   SUM = SUM + H(I)
      IF ( DABS(SUM - ONE) .GT. TOL )  THEN
        WRITE (NPRT,*) 'SUPPLIED SHAPE FUNCTIONS INCORRECT'
        WRITE (NPRT,*) 'SUM ', SUM
        CALL  RPRINT (H,1,N,1)
        WRITE (NPRT,*) 'END OF WARNING FROM SCHECK'
      ENDIF
      RETURN
      END
      SUBROUTINE  SET (NNPFIX,NNPFLO,NLPFIX,NLPFLO,MISCFX,
     1             MISCFL,IPTEST,LPTEST,NHOMO,LHOMO,M,N,NE,
     2             RATIO,MAXTYP,NELFRE,NDFREE,NFLUX,NG,LBN)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C            SET DIMENSIONS OF PROPERTIES ARRAYS
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     LPTEST > 0, ELEMENT PROPERTIES ARE DEFINED
C     IPTEST > 0, SOME PROPERTIES ARE DEFINED
C     NLPFIX = NUMBER OF FIXED PT ELEMENT PROP
C     NLPFLO = NUMBER OF FLOATING PT ELEMENT PROP
C     NNPFIX = NUMBER OF FIXED PT NUMBER PROP
C     NNPFLO = NUMBER OF FLOATING PT NUMBER PROP
C     MISCFL = NUMBER OF MISC FLOATING PT SYSTEM PROP
C     MISCFX = NUMBER OF MISC FIXED  PT SYSTEM PROP
C     LHOMO  = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS
C     NHOMO  = 1, IF  NODAL PROPERTIES ARE HOMOGENEOUS
C     MAXTYP = MAX ALLOWED CONSTRAINT TYPE
C     RATIO  = CONSTANT FOR ITER CONTROL, SEE MODEL
      RATIO  = 1.0
      MAXTYP = 5
      NELFRE = N*NG
      NDFREE = M*NG
      NFLUX  =  LBN*NG
      IF ( NFLUX .LT. 1 ) NFLUX = 1
      IPTEST = NNPFIX + NNPFLO + NLPFIX + NLPFLO
     1       + MISCFX + MISCFL
      LPTEST = NLPFIX + NLPFLO
      RETURN
      END
      SUBROUTINE  SHAPE (PT, H, N, NSPACE, LSHAPE, NG, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     EVALUATE C0 ELEMENT INTERPOLATION FUNCTIONS
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(N), PT(NSPACE), LNODE(N)
C     H      = ELEMENT INTERPOLATION FUNCTIONS AT PT
C     LNODE  = TOPOLOGY LIST, IF VARIABLE
C     LSHAPE = 1-LINE, 2-TRI, 3-QUAD, 4-HEX, 5-TET, 6-WEDGE,
C              7-USER DEFINED
C     N      = NUMBER OF NODES PER ELEMENT
C     NG     = NUMBER OF DEGREES OF FREEDOM PER NODE
C     NSPACE = NO OF SPATIAL DIMENSIONS
C     PT     = LOCAL COORD OF A POINT
C
C      BRANCH ON SHAPE, THEN NUMBER OF NODES
      IF ( LSHAPE .LE. 1 )  THEN
C-->     1-D ELEMENTS
        IF ( N .EQ. 2 ) CALL SHP2L (PT(1),H)
c       IF ( N .EQ. 3 ) CALL SHP3L (PT(1),H)
        RETURN
      ELSEIF ( LSHAPE .EQ. 2 ) THEN
C-->     TRIANGULAR 2-D ELEMENTS
        IF ( N .EQ. 3 )  CALL SHP3T (PT(1),PT(2),H)
C       IF ( N .EQ. 4 )  CALL SHP4T (PT(1),PT(2),H)
        IF ( N .EQ. 6 )  CALL SHP6T (PT(1),PT(2),H)
C       IF ( N .EQ. 7 )  CALL SHP7T (PT(1),PT(2),H)
C       IF ( N .EQ. 10 ) CALL SHP10T (PT(1),PT(2),H)
C       IF ( N .EQ. 15 ) CALL SHP15T (PT(1),PT(2),H)
        RETURN
      ELSEIF ( LSHAPE .EQ. 3 )  THEN
C-->     QUADRILATERAL 2-D ELEMENTS
        IF ( N .EQ. 4 )  CALL SHP4Q (PT(1),PT(2),H)
        IF ( N .EQ. 8 )  CALL SHP8Q (PT(1),PT(2),H)
        IF ( N .EQ. 9 )  CALL SHP9Q (PT(1),PT(2),H)
C       IF ( N .EQ. 12 ) CALL SHP412 (PT(1),PT(2),H,LNODE)
C       IF ( N .EQ. 16 ) CALL SHP16Q (PT(1),PT(2),H)
C       IF ( N .EQ. 17 ) CALL SHP17Q (PT(1),PT(2),H)
C       IF ( N .EQ. 25 ) CALL SHP25Q (PT(1),PT(2),H)
        RETURN
      ELSEIF ( LSHAPE .EQ. 4 )  THEN
C-->     HEXAHEDRA 3-D ELEMENTS
        IF ( N .EQ. 8 )  CALL SHP8H  (PT(1),PT(2),PT(3),H)
c       IF ( N .EQ. 20 ) CALL SHP208 (PT(1),PT(2),PT(3),H,LNODE)
C       IF ( N .EQ. 27 ) CALL SHP27H (PT(1),PT(2),PT(3),H)
C       IF ( N .EQ. 32 ) CALL SHP32H (PT(1),PT(2),PT(3),H)
        RETURN
      ELSEIF ( LSHAPE .EQ. 5 )  THEN
C-->     TETRAHEDRA 3-D ELEMENTS (PYRAMIDS)
c       IF ( N .EQ. 4 )  CALL SHP4P  (PT(1),PT(2),PT(3),H)
c       IF ( N .EQ. 10 ) CALL SHP10P (PT(1),PT(2),PT(3),H)
c       IF ( N .EQ. 21 ) CALL SHP21P (PT(1),PT(2),PT(3),H)
        RETURN
      ELSEIF ( LSHAPE .EQ. 6 )  THEN
C-->     WEDGE 3-D ELEMENTS 
        STOP 'NO WEDGE IN SHAPE'
C       IF ( N .EQ. 6 )  CALL SHP6W  (PT(1),PT(2),PT(3),H)
C       IF ( N .EQ. 15 ) CALL SHP15W (PT(1),PT(2),PT(3),H)
C       RETURN
      ELSEIF ( LSHAPE .EQ. 7 )  THEN
C-->     USER SUPPLIED ELEMENT
C       CALL SHPUSR (PT(1),PT(2),PT(3),H,LNODE)
        STOP 'NO USER ELEMENT IN SHAPE'
      ELSEIF ( LSHAPE .GT. 7 )  THEN
C-->     UNSUPPORTED OPTION
        STOP 'UNSUPPORTED ELEMENT IN SHAPE'
      ENDIF
      RETURN
      END
      SUBROUTINE  SHP16QS (R,S,H) 
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C       SHAPE FUNCTIONS FOR SERENDIPITY QUAD WITH 16 NODES
C                    A BI-4TH ORDER ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
      PARAMETER  ( PT667 = 0.66666666666667 )
      DIMENSION  H(16)
C     R,S = LOCAL COORDS OF PT     4--15--11---7---3
C     H = ELEM SHAPE FUNCTIONS     I               I
C                                  8       S      14
C     LNODE = ELEM INCIDENCES LIST I       .       I
C     ELEMENT SKETCH TO RIGHT     12       +..R   10
C                                  I               I
C     1@(-1,-1)  3@(+1,+1)        16               6
C                                  I               I
C                                  1---5---9--13---2
      RR = R*R
      SS = S*S
      RS = R*S
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      H(1)  = RM*SM*(-R*(4. * RR - 1.) - S*(4.*SS - 1.) - 3.)/12.
      H(5)  = -PT667*R*SM*RM*RP * (1. - 2.*R)
      H(9)  = 0.5*RM*RP * (1. - 4.*RR) * SM
      H(13) = PT667*R*SM*RM*RP * (1. + 2.*R)
      H(2)  = RP*SM*(R*(4.*RR - 1.) - S*(4.*SS - 1.) - 3.)/12.
      H(6)  = -PT667*S*RP*SM*SP * (1. - 2.*S)
      H(10) = 0.5*SM*SP*(1. - 4.*SS) * RP
      H(14) = PT667*S*RP*SM*SP * (1. + 2.*S)
      H(3)  = RP*SP*(R*(4.*RR - 1.) + S*(4.*SS - 1.) - 3.)/12.
      H(7)  = PT667*R*SP*RM*RP * (1. + 2.*R)
      H(11) = 0.5*RM*RP * (1. - 4.*RR) * SP
      H(15) = -PT667*R*SP*RM*RP * (1. - 2.*R)
      H(4)  = RM*SP*(-R*(4.*RR - 1.) + S*(4.*SS - 1.) - 3.)/12.
      H(8)  = PT667*S*SM*SP * (1. + 2.*S) * RM
      H(12) = 0.5*SM*SP * (1. - 4.*SS) * RM
      H(16) = -PT667*S*RM*SM*SP * (1. - 2.*S)
      RETURN
      END
      SUBROUTINE  SHP16R  (R,S,A,B,H)
C     * * * * * * * * * * * * * * * * * * * * * *
C     C1 RECTANGULAR ELEMENT IN UNIT COORDINATES
C       USING TENSOR PRODUCTS OF 1D BASIS
C     * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  H(16), HR(4), HS(4)
C     DOF ARE W W,X W,Y W,XY AT EACH NODE (NG=4)
C     X // R, Y // S.              S
C     A = PHYSICAL LENGTH IN X     4 -------- 3
C     B = PHYSICAL LENGTH IN Y     I          I
C     R,S = LOCAL UNIT COORDS      I          I
C     1@(0,0), 3@(1,1)             1 -------- 2 ->R
C
C     Evaluate the 1D interpolations
      CALL  SHPC1L (R,A,HR)
      CALL  SHPC1L (S,B,HS)
C     Form tensor products
      H(1) = HR(1)*HS(1)
      H(2) = HR(2)*HS(1)
      H(3) = HR(1)*HS(2)
      H(4) = HR(2)*HS(2)
      H(5) = HR(3)*HS(1)
      H(6) = HR(4)*HS(1)
      H(7) = HR(3)*HS(2)
      H(8) = HR(4)*HS(2)
      H(9) = HR(3)*HS(3)
      H(10) = HR(4)*HS(3)
      H(11) = HR(3)*HS(4)
      H(12) = HR(4)*HS(4)
      H(13) = HR(1)*HS(3)
      H(14) = HR(2)*HS(3)
      H(15) = HR(1)*HS(4)
      H(16) = HR(2)*HS(4)
      RETURN
      END
      SUBROUTINE  SHP17Q (R,S,H) 
C     ******************************************************************
C       SHAPE FUNCTIONS FOR A SERENDIPITY QUAD WITH 17 NODES
C     ******************************************************************
      PARAMETER  ( PT667 = 0.6666666666666667 )
      DIMENSION  H(17)
C     R,S = LOCAL COORDS OF PT     4--15--11---7---3
C     H = ELEM SHAPE FUNCTIONS     I               I
C                                  8       S      14
C     LNODE = ELEM INCIDENCES LIST I       I       I
C     ELEMENT SKETCH TO RIGHT     12      17-R    10
C                                  I               I
C     1@(-1,-1)  3@(+1,+1)        16               6
C     17@(0,0)                     I               I
C                                  1---5---9--13---2
      RR = R*R
      SS = S*S
      RS = R*S
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      H(1)  = RM*SM*(-4.*R*(RR - 1.) - 4.*S*(SS - 1.) + 3.*RS)/12.   
      H(5)  = -PT667*R*SM*RM*RP*(1. - 2.*R)
      H(9)  = 0.5*RM*RP*(-S - 4.*RR)*SM
      H(13) = PT667*R*SM*RM*RP*(1. + 2.*R)
      H(2)  = RP*SM*(4.*R*(RR - 1.) - 4.*S*(SS - 1.) - 3.*RS)/12.
      H(6)  = -PT667*S*RP*SM*SP*(1. - 2.*S)
      H(10) = 0.5*SM*SP*(R - 4.*SS)*RP
      H(14) = PT667*S*RP*SM*SP*(1. + 2.*S)
      H(3)  = RP*SP*(4.*R*(RR - 1.) + 4.*S*(SS - 1.) + 3.*RS)/12.
      H(7)  = PT667*R*SP*RM*RP*(1. + 2.*R)
      H(11) = 0.5*RM*RP*(S - 4.*RR)*SP
      H(15) = -PT667*R*SP*RM*RP*(1. - 2.*R)
      H(4)  = RM*SP*(-4.*R*(RR - 1.) + 4.*S*(SS - 1.) - 3.*RS)/12.
      H(8)  = PT667*S*SM*SP*(1. + 2.*S)*RM
      H(12) = 0.5*SM*SP*( -R - 4.*SS)*RM
      H(16) = -PT667*S*RM*SM*SP*(1. - 2.*S)
      H(17) = RM*RP*SM*SP
      RETURN
      END
      SUBROUTINE  SHP208 (R, S, T, H, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     ELEMENT INTERPOLATION FUNCTIONS FOR AN 8 TO 20 NODE HEXAHEDRON
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(20), LNODE(20), I1(20), I2(20)
      DATA I1 /8*0, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4/
      DATA I2 /8*0, 2, 3, 4, 1, 6, 7, 8, 5, 5, 6, 7, 8/
C     R,S,T = LOCAL COORDINATES OF THE POINT   -1 LE (R,S,T) LE +1
C     H     = ELEMENT INTERPOLATION FUNCTIONS, H(I) = 0 IF LNODE(I) = 0
C     LNODE = ARRAY OF ELEMENT INCIDENCES,  
C         IF LNODE(I)=0 THEN LOCAL NODE I IS NOT CONSIDERED IN ANALYSIS
C     I1, I2 = CORNER NODES OF TWELVE EDGES
C
C     A SKETCH OF THE LOCAL NODES...        T          3 *----*----* 2
C                                           :           /.    10  /:
C     FACES DEFINED BY R.H.R. ABOUT         :          / .       / :
C        THE POSITIVE LOCAL AXES            *---S     /  *19    /  *18
C      +R,(8,5,1,4,16,17,12,20)            /      11 *   .    9*   :
C      -R,(7,6,2,3,14,18,10,19)           /         /    .    /    :
C      +S,(6,2,1,5,18,9,17,13)           R         /    7*.../*....* 6
C      -S,(7,3,4,8,19,11,20,15)                   /  12 .   / 14  /
C      +T,(3,4,1,2,11,12,9,10)                 4 *----*----* 1   /
C      -T,(7,8,5,6,15,16,13,14)                  :    .    :    /
C     AND  R             FACE                    :   *15   :   * 13
C         7 V           7    V                20 *  .    17*  /
C        7   V         7      V                  : .       : /
C       T <<< S   COORD2 <<<< COORD1             :.   16   :/
C     ARE THE FACE COORD. PERMUTATIONS         8 *----*----* 5
C
      RP = 0.5*(1. + R)
      SP = 0.5*(1. + S)
      TP = 0.5*(1. + T)
      RM = 0.5*(1. - R)
      SM = 0.5*(1. - S)
      TM = 0.5*(1. - T)
      RZ = 1. - R*R
      SZ = 1. - S*S
      TZ = 1. - T*T
      H( 1) = TP*SP*RP
      H( 2) = TP*SP*RM
      H( 3) = TP*SM*RM
      H( 4) = TP*SM*RP
      H( 5) = TM*SP*RP
      H( 6) = TM*SP*RM
      H( 7) = TM*SM*RM
      H( 8) = TM*SM*RP
C      QUADRATIC EDGE BUBBLES
      H( 9) = TP*SP*RZ*0.5 
      H(10) = TP*SZ*RM*0.5 
      H(11) = TP*SM*RZ*0.5 
      H(12) = TP*SZ*RP*0.5  
      H(13) = TM*SP*RZ*0.5
      H(14) = TM*SZ*RM*0.5
      H(15) = TM*SM*RZ*0.5
      H(16) = TM*SZ*RP*0.5
      H(17) = TZ*SP*RP*0.5
      H(18) = TZ*SP*RM*0.5
      H(19) = TZ*SM*RM*0.5
      H(20) = TZ*SM*RP*0.5
C      LOOP OVER TWELVE ELEMENT EDGES
      DO 20  K = 9,20
        IF ( LNODE(K) .EQ. 0 )  THEN
C          SET UNUSED EDGE BUBBLE TO ZERO
          H(K) = 0.0
        ELSE
C          ENRICH THE TWO CORNERS ON THE EDGE
          HK = H(K)
          K1 = I1(K)
          K2 = I2(K)
          H(K1) = H(K1) - HK
          H(K2) = H(K2) - HK
          H(K) = HK + HK
        ENDIF
   20 CONTINUE
      RETURN
      END
      SUBROUTINE  SHP2L (R,H)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS OF A 2 NODE LINE ELEMENT
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION H(2)
C     R IS UNIT COORD.   R=-1  1------------2  R=1
      H(1) = 0.5*(1.0-R)
      H(2) = 0.5*(1.0+R)
      RETURN
      END
      SUBROUTINE  SHP3L (X, H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CALCULATE SHAPE FUNCTIONS OF A 3 NODE LINE ELEMENT
C                 IN NATURAL COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(3)
C     H = ELEMENT SHAPE FUNCTIONS
C     X = LOCAL COORDINATE OF POINT,    -1 TO +1
C     LOCAL NODE COORD. ARE -1,0,+1.   1-----2-----3
      H(1) = 0.5*(X*X - X)
      H(2) = 1. - X*X
      H(3) = 0.5*(X*X + X)
      RETURN
      END
      SUBROUTINE  SHP3T (S, T, H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS FOR A THREE NODE UNIT TRIANGLE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(3)
C     S,T = LOCAL COORDINATES OF THE POINT    3     T
C     H   = SHAPE FUNCTIONS                   . .   .
C     NODAL COORDS 1-(0,0)  2-(1,0)  3-(0,1)  1..2  0..S
      H(1) = 1. - S - T
      H(2) = S
      H(3) = T
      RETURN
      END
      SUBROUTINE  SHP412 (R, S, H, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        SHAPE FUNCTIONS OF 4 TO 12 NODE QUADRILATERAL
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(12), LNODE(12), IP(4), JP(4), NEXT(4)
      DATA IP,JP,NEXT /1,0,-1,0,  0,1,0,-1,  2,3,4,1/
C     R,S = LOCAL COORDS OF PT     4--11---7---3
C     H = ELEM SHAPE FUNCTIONS     :     S     :
C     LNODE = ELEM INCIDENCES LIST 8     :    10
C     ELEMENT SKETCH TO RIGHT      :     *..R  :
C     LOCAL COORD OF NODES:       12           6
C     1-(-1,-1)  3-(+1,+1)         :           :
C     SIDES OF ORDER 1, 2, OR 3    1---5---9---2
C-->   GENERATE FOUR NODE BILINEAR QUADRILATERAL
      CALL  SHP4Q (R,S,H)
C-->   LOOP OVER SIDES
      DO 10  I = 1,4
        H(I+4) = 0.
        H(I+8) = 0.
C        IS SIDE HIGHER THAN LINEAR ?
        IF ( LNODE(I+4) .GT. 0 )  THEN
          K = NEXT(I)
C          FIND PT RELATIVE TO SIDE (CYCLIC COORDINATES)
          P    = R*IP(I) + S*JP(I)
          Q    =-R*JP(I) + S*IP(I)
          TEMP = (1. - Q)*0.5
C-->       IS SIDE QUADRATIC OR CUBIC ?
          IF ( LNODE(I+8) .GT. 0 )  THEN
C            CUBIC
            H(I+8) = TEMP*(1. - 3.*P - P*P + 3.*P*P*P)*9./16.
            H(I+4) = TEMP*(1. + 3.*P - P*P - 3.*P*P*P)*9./16.
C            CORRECT CORNER POINTS FOR CUBIC
            H(I) = H(I) - H(I+4)*2./3. - H(I+8)/3.
            H(K) = H(K) - H(I+8)*2./3. - H(I+4)/3.
          ELSE
C            QUADRATIC 
            H(I+4) = TEMP*(1. - P*P)
C            CORRECT CORNER POINTS FOR QUADRATIC
            H(I) = H(I) - H(I+4)*0.5
            H(K) = H(K) - H(I+4)*0.5
          ENDIF
        ENDIF
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  SHP4Q (R, S, H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS OF A 4 NODE ISOPARAMETRIC QUAD
C              IN NATURAL COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION H(4)
C     (R,S) = A POINT IN THE NATURAL COORDS     4--3
C     H     = LOCAL INTERPOLATION FUNCTIONS     I  I
C     H(I)  = 0.25*(1+R*R(I))*(1+S*S(I))        I  I
C     R(I)  = LOCAL R-COORDINATE OF NODE I      1--2
C     LOCAL COORDS, 1=(-1,-1)   3=(+1,+1)
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      H(1) = 0.25*RM*SM
      H(2) = 0.25*RP*SM
      H(3) = 0.25*RP*SP
      H(4) = 0.25*RM*SP
      RETURN
      END
      SUBROUTINE  SHP6T (S,T,H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     LOCAL SHAPE FUNCTIONS FOR A SIX NODE UNIT TRIANGLE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(6)
C     S,T = LOCAL COORDINATES                       3
C           OF A POINT IN THE UNIT TRIANGLE
C     H = SIX SHAPE FUNCTIONS FOR A QUADRATIC  T    6 5
C         ELEMENT  WITH SIX NODES              :
C     THE NODAL ORDER IS SHOWN TO THE RIGHT    .-S  1 4 2
C     NODAL COORDS : 1-(0,0)   2-(1,0)   3-(0,1)
C                    4-(0.5,0)  5-(0.5,0.5)  6-(0,0.5)
      H(1) = 1. - 3.*S - 3.*T + 2.*S*S + 4.*S*T + 2.*T*T
      H(2) = 2.*S*S - S
      H(3) = 2.*T*T - T
      H(4) = 4.*(S - S*S - S*T)
      H(5) = 4.*S*T
      H(6) = 4.*(T - S*T - T*T)
      RETURN
      END
      SUBROUTINE  SHP8H (R,S,T,H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS OF 8 NODE ISOPARAMETRIC HEXAHEDRON
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(8)
C     R,S,T = LOCAL COORDS OF PT         | T
C     H = ELEM SHAPE FUNCTIONS         6/--/5
C     NODES ORDERED BY RHR             /  / |
C     ABOUT THE R-AXIS              2/--/1 /|--S
C     LOCAL COORD:1=(1,1,1)          |  : /  8
C     4=(1,1,-1)  7=(-1,-1,-1)    R 3|--|/ 4
      RP = 1. + R
      RM = 1. - R
      SP = 1. + S
      SM = 1. - S
      TP = 1. + T
      TM = 1. - T
      H(1) = 0.125*RP*SP*TP
      H(2) = 0.125*RP*SM*TP
      H(3) = 0.125*RP*SM*TM
      H(4) = 0.125*RP*SP*TM
      H(5) = 0.125*RM*SP*TP
      H(6) = 0.125*RM*SM*TP
      H(7) = 0.125*RM*SM*TM
      H(8) = 0.125*RM*SP*TM
      RETURN
      END
      SUBROUTINE  SHP8Q (S,T,H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS OF 8 NODE ISOPARAMETRIC QUADRILATERAL
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION H(8)
C     NODAL ORDER SHOWN TO RIGHT.                4 - 7 - 3
C     S,T = LOCAL COORDINATES OF POINT           :   T   :
C     H = SHAPE FUNCTION ARRAY                   8   *S  6
C     NODE 1 AT (-1,-1)                          :       :
C     NODE 3 AT (1,1)                            1 - 5 - 2
      SP = 1. + S
      SM = 1. - S
      TP = 1. + T
      TM = 1. - T
      H(1) = 0.25*SM*TM*( SM + TM - 3. )
      H(2) = 0.25*SP*TM*( SP + TM - 3. )
      H(3) = 0.25*SP*TP*( SP + TP - 3. )
      H(4) = 0.25*SM*TP*( SM + TP - 3. )
      H(5) = 0.5*TM*( 1. - S*S )
      H(6) = 0.5*SP*( 1. - T*T )
      H(7) = 0.5*TP*( 1. - S*S )
      H(8) = 0.5*SM*( 1. - T*T )
      RETURN
      END
      SUBROUTINE  SHP9Q ( R, S, H )
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS FOR 9-NODED QUAD
C     * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(9)
C     R,S = LOCAL COORDS OF PT     4-----7-----3
C     H = ELEM SHAPE FUNCTIONS     I     S     I
C     LNODE = ELEM INCIDENCES LIST I     .     I
C     ELEMENT SKETCH TO RIGHT      8     9..R  6
C     1@(-1,-1)  3@(+1,+1)         I           I
C                                  I           I
C                                  1-----5-----2
      RM = R - 1.D0
      SM = S - 1.D0
      RP = R + 1.D0
      SP = S + 1.D0
      H(1) = 0.25D0 *S * SM * R * RM
      H(2) = 0.25D0 * S * SM* R * RP
      H(3) = 0.25D0 * S* SP * R * RP
      H(4) = 0.25D0 * S * SP * R * RM
      H(5) = -0.5D0 * S * SM * RP * RM
      H(6) = -0.5D0 * SP *SM * R* RP
      H(7) = -0.5D0 * S * SP * RP * RM
      H(8) = -0.5D0 * SP * SM* R * RM 
      H(9) = SP * SM * RP * RM
      RETURN 
      END
      SUBROUTINE  SHPCU (B, A, H)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SHAPE FUNCTIONS FOR A CUBIC HERMITE, UNIT COORD
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(4)
C     A = LENGTH OF ELEMENT     1----------2 -> B
C     B = COORDINATE OF POINT  B=0         B=1
C     H = SHAPE FUNCTIONS ARRAY
      H(1) = 1.-3.*B*B + 2.*B*B*B
      H(2) = (B - 2.*B*B + B*B*B)*A
      H(3) = 3.*B*B - 2.*B*B*B
      H(4) = (B*B*B - B*B)*A
      RETURN
      END
      SUBROUTINE  SHPHQL (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE,
     &                    RST, VALUE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C             SHAPE FUNCTIONS FOR GENERAL SERENDIPITY 
C               LINE, QUAD, OR OR HEXAHEDRON WITH AN 
C              ARBITRARY NUMBER OF NODES ON EACH EDGE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER  ( MAXDEG = 20 )
      DIMENSION  RST(3),     BLKCRD(3,8), POLI2(3),  CDRFN(3), 
     &           FARSID(3),  CRDEDG(3,MAXDEG+1), 
     &           NODEDG(12), NEATC(3,8),  NODEOP(2,12), 
     &           NODATC(3),  LOCAL(12)
      DATA BLKCRD
     &/ -1.,-1.,-1.,   1.,-1.,-1.,   1.,1.,-1.,   -1.,1.,-1.,
     &  -1.,-1., 1.,   1.,-1., 1.,   1.,1., 1.,   -1.,1., 1./
      DATA NEATC /  1,4,9,   1,2,10,  3,2,11,  3,4,12,
     &              5,8,9,   5,6,10,  7,6,11,  7,8,12 /
      DATA NODEOP / 7,8,  8,5,  5,6,   6,7,
     &              3,4,  4,1,  1,2,   2,3,
     &              3,7,  4,8,  1,5,   2,6 /
      DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 /
C     BLKCRD  = BLOCK CORNER LOCAL COORDINATES
C     CRDEDG  = LOCAL COORDINATES OF SIDE NODES JOINING CORNER
C     FARSID  = FAR SIDE LOCAL COORDINATE
C     LEDGES  = NUMBER OF ELEMENT EDGES, 1, 4, OR 12
C     LOCAL   = LOCAL COORDINATE PARALLEL TO EACH EDGE
C     LOCATE  = POSITION NUMBER ON EDGE, 0 IF CORNER
C     MAXDEG  = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE
C     NEATC   = THE 1, 2, OR 3 EDGES AT A CORNER
C     NEDGE   = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED
C     NODATC  = NUMBER OF SIDE NODES JOINING A CORNER
C     NODEDG  = NUMBER ON NODES ON 1,4, OR 12 EDGES
C     NODEOP  = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE
C     NSPACE  = NUMBER OF SPATIAL DIMENSIONS
C     RST     = LOCAL COORDINATES FOR EVALUATION
C     VALUE   = SHAPE FUNCTION VALUE (RETURNED)
C
C     VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT )
C
C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE
C      FUNCTIONS IN SERENDIPITY ELEMENTS", ENG COMP,8,19-31,1991
C
C   T:  S      C8 *---E7----* C7     T:  S         8---15----7   
C    : /         /.        /:         : /         /.        /:
C    :/         / .       / :         :/         / 22      / :
C    *---R     / E12     /  E11       *---R     /  .      /  20 
C            E8   .     E6  :                 16   21    /   :
C            /    .    /    :                 /    .    /    :
C           /   C4*.../.E3..* C3             /     4.13/.12..3   
C          /     .   /     /                /     .   /     /
C      C5 *--E5-----* C6  /                5---------6     /
C         :    .    :    /                 :    .    :    11
C         :  E4     :   E2                 :  14    19   /   
C        E9  .    E10  /                  17  .      :  10
C         : .       : /                    : .      18 /
C         :.        :/                     :.        :/
C      C1 *---E1----* C2                   1----9----2
C CORNER NODE & EDGE NUMBERS.   22 NODES: CORNERS, THEN BY EDGES. 
C                               CCW IF |T|=1, ELSE IN POSITIVE T.
C                       === 3-D FORM ===
C
C      C4 *---E3----* C3                   4----8----3     
C         :    .    :         :S           :         :   
C         :         :         :            :         :
C        E4        E2         :            9         :  
C         :         :         *---R        :         :
C         :         :                      :         :
C      C1 *---E1----* C2                   1--5-6-7--2 
C CORNER NODE & EDGE NUMBERS.  9 NODES: CORNERS, THEN BY EDGE ORDER.
C                        === 2-D FORM ===
C
C      C1 *---E1----* C2                   1--2-3-4--5 
C CORNER NODE & EDGE NUMBERS.       9 NODES NUMBERED BY EDGE ORDER.
C                        === 1-D FORM ===
      POLI1 = 1.
      IF ( LOCATE .EQ. 0 ) THEN
C
C  SHAPE FUNCTION FOR CORNER NODES
C
        DO 100 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE))
     &            /(2*BLKCRD(ICORD,NEDGE))
  100   CONTINUE
        CPNUL = 1.
        POLI2(1) = 0.
        POLI2(2) = 0.
        POLI2(3) = 0.
        DO 200 ICORD = 1,NSPACE
          NSIDE = NEATC(ICORD,NEDGE)
          NODATC(ICORD) = NODEDG(NSIDE) - 2
          IF ( NODATC(ICORD) .GT. 0 ) THEN
            IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, SHPHQL'
            CPNUL = CPNUL - 1.
            POLI2(ICORD) = 1.
            FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1)
            DO 300 INODE = 1,NODATC(ICORD)
              CRDEDG(ICORD,INODE) =  -1. + FARSID(ICORD)*INODE
              POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) 
     &                     - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE)
     &                     - CRDEDG(ICORD,INODE))
  300       CONTINUE
          ENDIF
  200   CONTINUE
        VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL)
      ELSE
C
C  SHAPE FUNCTION FOR EDGE NODES
C
        NOPV1 = NODEOP(1,NEDGE)
        NOPV2 = NODEOP(2,NEDGE)
        ISRFN = ABS(LOCAL(NEDGE))
        FARSID(1) = 2./(NODEDG(NEDGE) - 1)
        CDRFN(1) =  -BLKCRD(1,NOPV1)
        CDRFN(2) =  -BLKCRD(2,NOPV1)
        CDRFN(3) =  -BLKCRD(3,NOPV1)
        CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN
        DO 400 ICORD = 1,NSPACE
          POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1))
     &           /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1))
  400   CONTINUE
        PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2))
     &         /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2))
        POLI3 = 1.
        NODATC(1) = NODEDG(NEDGE) - 2
        IF ( NODATC(1) .GT. 0 ) THEN
          IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, SHPHQL'
          DO 500 INODE = 1,NODATC(1)
            CRDEDG(1,INODE) =  -1. + FARSID(1)*INODE
            IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001)
     &      THEN
              POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE))
     &               /(CDRFN(ISRFN) - CRDEDG(1,INODE))
            ENDIF
  500     CONTINUE
        ENDIF
        VALUE = POLI1*PLAN2*POLI3
      ENDIF
      RETURN
      END
      SUBROUTINE  SHPLEG (N, X, P, DPDX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     RECURSION RELATIONS FOR LEGENDRE POLYNOMIALS
C     TO DEGREE N, AND THEIR LOCAL DERIVATIVES ON 0,1
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  P(0:N), DPDX(0:N)
C      RECOMMEND THAT X BE DOUBLE PRECISION
      P(0)    = 1.D0
      DPDX(0) = 0.D0
      IF ( N .LT. 1 )  RETURN
      DPDX(1) = 1.D0
      P(1)    = X
      IF ( N .GT. 1 )  THEN
        DO 10  J = 2, N
          P(J)    = ( (J + J - 1)*X*P(J-1) - (J - 1)*P(J-2) )/J
          DPDX(J) = ( (J + J - 1)*X*DPDX(J-1) - J*DPDX(J-2))/(J-1)
  10    CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE  SINGLR (P, H, DH, N, NSPACE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C      CONVERT STANDARD FUNCTIONS TO SINGULAR FUNCTIONS
C     WITH DERIV SINGULARITIES AT NODE 1 OF O(R**(-P))
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(N), DH(NSPACE,N)
C     H      = SHAPE FUNCTION ARRAY (STANDARD)
C     DH     = LOCAL DERIVATIVES OF H (STANDARD)
C     N      = NUMBER OF SHAPE FUNCTIONS 
C     NSPACE = DIMENSION OF SPACE
C      REQUIRES SUM OF H(I) = 1, & CONST JACOBIAN
      IF ( P .EQ. 0.0 )  RETURN
      W = 1.0 - H(1)
      R = W**P
      DO 20  I = 1,NSPACE
        DO 10  J = 2,N
   10   DH(I,J) = DH(I,J)/R + P*DH(I,1)*H(J)/R/W
        DH(I,1) = (1.0 - P)*DH(I,1)/R
   20 CONTINUE
      DO 30  J = 2,N
   30 H(J) = H(J)/R
      H(1) = 1.0 - W/R
      RETURN
      END
      SUBROUTINE  SIZEI (LOC,NEXTI,IN,IPT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        LIST NAMES AND SIZES OF INTEGER SUB-ARRAYS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 IN
      DIMENSION  IPT(1), IN(1)
C
C     IN    = Names of sub-arrays in I array
C     IPT   = pointer array for sub-arrays in I
C     LOC   = Array location. If < 1 list all.
C     NEXTI = Next free sub-array in I
C
      K1 = 1
      K2 = NEXTI - 1
      IF  ( LOC .GE. 1 ) THEN
        K1 = LOC
        K2 = LOC
      ENDIF
      WRITE (6,100)
 100  FORMAT ( /,' INTEGER SUB-ARRAY DATA:', /,
     1 ' NUMBER  NAME     BEGINNING      SIZE')
      DO 10 K = K1, K2
      ISIZE = IPT(K+1) - IPT(K)
 10   WRITE (6,200) K, IN(K), IPT(K), ISIZE
 200  FORMAT ( I7, 2X, A8, I10, I10 )
      RETURN
      END
      SUBROUTINE  SIZER (LOC,NEXTR,RN,JPT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        LIST NAMES AND SIZES OF REAL SUB-ARRAYS
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      CHARACTER*8 RN
      DIMENSION  JPT(1), RN(1)
C
C     JPT   = pointer array for sub-arrays in R
C     LOC   = Array location. If < 1 list all.
C     NEXTR = Next free sub-array in R
C     RN    = Names of sub-arrays in R array
C
      K1 = 1
      K2 = NEXTR - 1
      IF  ( LOC .GE. 1 ) THEN
        K1 = LOC
        K2 = LOC
      ENDIF
      WRITE (6,100)
 100  FORMAT ( /,' REAL SUB-ARRAY DATA:', /,
     1 ' NUMBER  NAME     BEGINNING      SIZE')
      DO 10 K = K1, K2
      ISIZE = JPT(K+1) - JPT(K)
 10   WRITE (6,200) K, RN(K), JPT(K), ISIZE
 200  FORMAT ( I7, 2X, A8, I10, I10 )
      RETURN
      END
      SUBROUTINE  SKYCHK (NDFREE, NCOEFF, M, NG, S, C, IDIAG)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C      CHECK BANDED SYSTEM FOR INVALID EQUATIONS & WARN
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H, O-Z)
      PARAMETER ( NPRT = 6, ZERO = 0.0 )
      DIMENSION  S(NCOEFF), C(NDFREE), IDIAG(NDFREE)
C     C      = SYSTEM COLUMN MATRIX
C     IDIAG  = POINTER TO DIAGONAL COEFFICIENT IN S
C     S      = SYSTEM SQUARE MATRIX IN BANDED MODE
C     NCOEFF = NUMBER OF COEFFICIENTS IN S
C     NDFREE = NUMBER OF EQUATIONS
      SMAX = ZERO
      DO 10 I = 1, NDFREE
        TEST = ABS( S( IDIAG(I) ) )
        IF ( TEST .GT. SMAX ) SMAX = TEST
  10  CONTINUE
      IF ( SMAX .LE. ZERO )  STOP  
     1    'ALL ELEMENT STIFFENESSES ZERO, BANCHK'
      K = 0
      DO 20 I = 1, M
        DO 30 J = 1, NG
          K = K + 1
          TEST = S( IDIAG(K) )
          IF ( TEST .LE. ZERO  )  THEN
            IF ( TEST .EQ. ZERO  )  WRITE (NPRT,200) I, J
 200        FORMAT ('WARNING, NODE ',I5,' DOF',I3,' WAS RESTRAINED')
            IF ( TEST .LT. ZERO  )  WRITE (NPRT,300) I, J
 300        FORMAT ('ERROR, NODE ',I5,' DOF',I3,' WAS RESTRAINED')
C            SET DOF K TO ZERO
            CALL SKYTY1 (NDFREE, NCOEFF, K, ZERO, S, C, IDIAG)
          ENDIF
  30    CONTINUE
  20  CONTINUE
      RETURN
      END
      SUBROUTINE  SKYDIA (NDFREE, IDOFHI, IDIAG)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C     USE COLUMN HEIGHTS TO FIND DIAGONAL COEFFICIENTS
C     FOR SYMMETRIC SKYLINE STORAGE MODE
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C      ASSUMING SYMMETRIC COLS STORED FROM TOP DOWN
      DIMENSION  IDOFHI(NDFREE), IDIAG(NDFREE)
C     NDFREE    = TOTAL NO OF SYSTEM EQUATIONS
C     IDOFHI(I) = COL HEIGHT OF EQ I, WITH DIAG
C     IDIAG(I)  = LOCATION OF DIAG OF I-TH EQ NUMBER
C                 COEFF IN UPPER TRIANGLE 
C      TOTAL NUMBER OF SQ MATRIX TERMS = IDIAG(NDFREE)
      IPOINT = 0
      DO 10  I = 1, NDFREE
        IPOINT = IPOINT + IDOFHI(I)
 10   IDIAG(I) = IPOINT
      RETURN
      END
      SUBROUTINE  SKYEBC (NDFREE, NOCOEF, N, VALUE, S, C, IDIAG)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY TYPE 1 MODIFICATION TO SYMMERTIC SKYLINE EQS
C          S*D = C,  D(N) = VALUE
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  S(NOCOEF), C(NDFREE), IDIAG(NDFREE)
C     NDFREE = DFREE NUMBER OF EQUATIONS
C     NOCOEF = NUMBER OF NON-ZERO COEFFICIENTS IN S
C     N      = DOF NUMBER OF CONSTRAINED PARAMETER
C     VALUE  = GIVEN VALUE OF DOF NUMBER N
C     S      = SYSTEM SQUARE MATRIX IN SKYLINE STORAGE MODE
C     C      = FULL COLUMN MATRIX
C     IDIAG  = POINTER TO DIAGONAL COEFFICIENT IN S
C      SUBTRACT COLUMN*VALUE FROM RHS
      DO 10  I = 1, NDFREE
C        FIND S(I,N) IN S VECTOR
        ID   = MAX0(I,N)
        INV  = IDIAG(ID) - IABS(I-N)
        ITOP = 1
        IF ( ID .GT. 1 )  ITOP = IDIAG(ID - 1) + 1
C        IS IT OUTSIDE SKYLINE AND THUS ZERO?
        IF ( INV .GE. ITOP )  THEN
          C(I)   = C(I) - VALUE*S(INV)
          S(INV) = 0.0
        ENDIF
  10  CONTINUE
C      RESET THE EQUATION ROW
      S(IDIAG(N)) = 1.0
      C(N)        = VALUE
      RETURN
      END
      SUBROUTINE  SKYFAC (NDFREE,NOCOEF,IDIAG,S)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     L*D*LT FACTORIZATION OF SYSTEM SQUARE MATRIX S
C     STORED IN SYMMETRIC SKYLINE VECTOR MODE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  S(NOCOEF), IDIAG(NDFREE)
C     NDFREE = TOTAL NUMBER OF SYSTEM DOF
C     NOCOEF = IDIAG(NDFREE) = NO OF COEFFS IN S
C     IDIAG(I) = LOCATION OF DIAGONAL OF EQ I
C     S = SYSTEM SQUARE MATRIX
      ZERO = 0.0
      if ( zero .eq. zero ) stop 'fatal logic for height=1'
C     FACTOR OFF DIAGONAL TERMS
      DO 300  J = 2,NDFREE
      JOFF = IDIAG(J) - IDIAG(J-1) - 1
      JTOP = J - JOFF
      ISTART = JTOP + 1
      ISTOP = J - 1
      JD = IDIAG(ISTOP) - JTOP + 1
      IF ( ISTART.GT.ISTOP )  GO TO 110
      DO 100  I = ISTART,ISTOP
      IOFF = IDIAG(I) - IDIAG(I-1) - 1
      ITOP = I - IOFF
      NUM = MAX0 (ITOP,JTOP)
      NEND = I - NUM
      IJV = JD + I
      IL = IDIAG(I-1) + NUM - ITOP + 1
      JG = JD + NUM
 100  S(IJV) = S(IJV) - DOT(NEND,S(IL),S(JG))
C     FACTOR DIAGONAL
 110  ISTART = JTOP
      IF ( ISTART.GT.ISTOP )  GO TO 300
      SUM = ZERO
      DO 200  I = ISTART,ISTOP
      IF ( S(IDIAG(I)).LE.ZERO )  GO TO 200
      D = S(I+JD)/S(IDIAG(I))
      SUM = SUM + S(I+JD)*D
      S(I+JD) = D
 200  CONTINUE
      S(IDIAG(J)) = S(IDIAG(J)) - SUM
 300  CONTINUE
      RETURN
      END
      SUBROUTINE  SKYFUL (NDFREE, NOCOEF, S, IDIAG, FULL, C)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     COPY SKYLINE S INTO SYMMETRIC FULL S AND PRINT WITH C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  S(NOCOEF), FULL(NDFREE,NDFREE), 
     1           C(NDFREE), IDIAG(NDFREE)
      DO 10  I = 1, NDFREE
        DO 20  J = I, NDFREE
          FULL(I, J) = 0.0
C          FIND S(I, J) IN S VECTOR
          ID   = MAX0(I, J)
          IJV  = IDIAG(ID) - IABS(I-J)
          ITOP = 1
          IF ( ID .GT. 1 )  ITOP = IDIAG(ID - 1) + 1
C          IS IT OUTSIDE SKYLINE AND THUS ZERO?
          IF ( IJV .LT. ITOP )  GO TO 20
            FULL(I, J) = S(IJV)
            FULL(J, I) = FULL(I, J)
  20    CONTINUE
  10  CONTINUE
      CALL  RPRINT (FULL, NDFREE, NDFREE, 0)
      CALL  RPRINT (C, NDFREE, 1, 0)
      RETURN
      END
      SUBROUTINE  SKYHI (NDFREE, NE, N, NG, NELFRE, NODES, 
     1                   LNODE, INDEX, LHIGH, IDOFHI)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C         FIND COLUMN HEIGHTS OF SYSTEM EQUATIONS IN
C               SYMMETRIC SKYLINE STORAGE MODE
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  NODES(NE,N), LNODE(N), INDEX(NELFRE),
     1           LHIGH(NELFRE), IDOFHI(NDFREE)
C     NDFREE    = TOTAL NO OF SYSTEM DOF
C     NELFRE    = NUMBER OF ELEMENT PARAMETERS (DOF)
C     NE        = NUMBER OF ELEMENTS
C     N         = NUMBER OF NODES PER ELEMENT
C     NG        = NUMBER OF PARAMETERS PER NODE
C     NODES     = NODAL INCIDENCES OF ALL ELEMENTS
C     LNODE     = ELEMENT NODAL INCIDENCES
C     INDEX(I)  = SYS DOF NUMBER OF ELEMENT DOF I
C     IDOFHI(I) = COL HEIGHT OF SYS DOF I
C
C      ZERO HEIGHTS
      CALL  ZEROI (NDFREE,IDOFHI)
C      LOOP OVER ELEMENTS
      DO 20  IE = 1, NE
C        EXTRACT NODES,  FIND DOF NOS
        CALL LNODES (IE, NE, N, NODES, LNODE)
        CALL INDXEL (N, NELFRE, NG, LNODE, INDEX)
C        FIND ELEMENT COLUMN HEIGHTS
        CALL ELHIGH (NELFRE, INDEX, LHIGH)
C        COMPARE WITH CURRENT MAXIMUMS
        DO 10  J = 1, NELFRE
          NDX = INDEX(J)
          IF ( NDX .LT. 1 )  GO TO 10
            IF ( IDOFHI(NDX) .LT. LHIGH(J) )
     1           IDOFHI(NDX) = LHIGH(J)
 10     CONTINUE
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  SKYLCE (NDFREE, S, C, NCD, NDX, A, NOCOEF, IDIAG)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     APPLY LINEAR CONSTRAINTS TO SKYLINE SYMMETRIC EQUATIONS
C                 S*D = C,  WITH S IN VECTOR MODE AND
C     D(NDX(1))+A(1)*D(NDX(2))+...A(NCD-1)*D(NDX(NCD))=A(NCD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( ZERO = 0.0, ONE = 1.0 )
      DIMENSION  S(NOCOEF), C(NDFREE), A(NCD), IDIAG(NDFREE),
     1           NDX(NCD)
      LOGICAL    SKIP
C     NCOEFF = NUMBER OF TERMS FOR SQ MATRIX IN VECTOR MODE
C     NCD    = TOTAL NUMBER OF DOF IN CONSTRAINT EQUATION
C     NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM
C     NDX(I) = SYS DOF NOS OF CONSTRAINT TERM I
C     NR     = REDUNDANT DEGREE OF FREEDOM = NDX(1)
C     A(J)   = NORMALIZED COEFF OF (J+1) TERM, A0 = 1.0
C     C = SYSTEM COLUMN MATRIX  : SII SIR SID : :DI: :CI:
C     S = SYSTEM SQUARE MATRIX  : SRI SRR SRD : :DR:=:CR:
C     R-REDUNDANT, D-DEPENDENT  : SDI SDR SDD : :DD: :CD:
C
      E     = A(NCD)
      NR    = NDX(1)
      SRR   = S(IDIAG(NR))
      SRRP1 = SRR + ONE
      CR    = C(NR)
      ESC   = E*SRRP1 - CR
C      FIND TOP AND BOTTOM OF THE SKYLINE OF THE NR COLUMN 
      CALL  SKYTAL ( NDFREE, IDIAG, NR, ITOP, IBOT )
C      FORM MODIFIED COLUMN MATRIX, CX = CX - E*SXR
      IF ( E .NE. ZERO )  THEN    
        DO 10  I = ITOP, IBOT
           CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV )
           IF ( INRV .NE. 0 )  C(I) = C(I) - E*S(INRV)
  10    CONTINUE
      ENDIF
C      ADDITIONAL COLUMN CHANGES FOR CD AND CR
      IF ( NCD .GT. 1 .AND. ESC .NE. ZERO )  THEN    
        DO 30  K = 2, NCD
   30   C( NDX(K) ) = C( NDX(K) ) + A(K-1)*ESC
      ENDIF
      C(NR) = E
C        *** SQUARE MATRIX COLUMN MODIFICATIONS ***
      IF ( NCD .GT. 1 )  THEN
C        FORM SID,  BEGIN SDD
        DO 60  K = 2, NCD
          J = NDX(K)
          DO 50  I =  ITOP, IBOT
            CALL  SKYSUB ( NDFREE, IDIAG, I, J, IJV )
            CALL  SKYSUB ( NDFREE, IDIAG, I, NR, INRV )
            IF ( INRV .NE. 0  .AND. S(INRV) .NE. 0.0 ) THEN
              IF ( IJV .EQ. 0 ) STOP 'INVALID ADDRESS, SKYLCE'
C             DO  NOT MODIFY NR  COLUMN, MAY NEED IT LATER
              SKIP = .FALSE.
              DO 40 LL = K+1, NCD
                IF ( I .EQ. NDX(LL) )  SKIP= .TRUE.
  40          CONTINUE
              IF ( (.NOT. SKIP) .AND. I .NE. NR )   
     1          S(IJV) = S(IJV) - S(INRV)*A(K-1)
            ENDIF
   50     CONTINUE
   60   CONTINUE
C      COMPLETE SDD
        DO 80  K = 2, NCD
          I = NDX(K)
          DO 70  L = 2, K
            J = NDX(L)
            CALL  SKYSUB ( NDFREE, IDIAG, I, J, IJV )
            CALL  SKYSUB ( NDFREE, IDIAG, I, NR, INRV )
            IF ( IJV .EQ. 0 .OR. INRV .EQ. 0 )
     1        STOP 'INVALID ADDRESS, SKYLCE' 
            S(IJV) = S(IJV) + SRRP1*A(K-1)*A(L-1) 
     1             - A(L-1)*S(INRV)
   70     CONTINUE
   80   CONTINUE
      ENDIF
C            *** INSERT CONSTRAINT EQUATION ***
C     WARNING: NEXT LOOP NOT VALID FOR COUPLED CONSTRAINTS
      DO 90  I = ITOP, IBOT
        CALL  SKYSUB ( NDFREE, IDIAG, I, NR, INRV )
        IF ( INRV .NE. 0 ) S(INRV) = ZERO
   90 CONTINUE
      S(IDIAG(NR)) = 1.0
      IF ( NCD .GT. 1 )  THEN
        DO 100  K = 2, NCD
          I = NDX(K)
          CALL  SKYSUB ( NDFREE, IDIAG, I, NR, INRV )
          IF ( INRV .EQ. 0 ) STOP 'INVALID ADDRESS, SKYLCE'
          S(INRV) = A(K-1)
  100   CONTINUE
C       *** MODIFICATIONS COMPLETED, CHECK DIAGONAL ***
        DO 110  K = 2, NCD
          I = NDX(K)
          IF ( S(IDIAG(I)) .LE. ZERO )  WRITE (6,*) 
     1      'NEGATIVE DIAGONAL FOR CONSTRAINT SET', NDX
  110   CONTINUE
      ENDIF
      RETURN
      END

      SUBROUTINE  SKYSOL (NDFREE,NOCOEF,IDIAG,S,C,D)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FOWARD AND BACK SUBSTITUTION OF L*D*LT
C     FACTORIZATION OF SYSTEM EQS  S*D=C
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     S IN SYMMERIC SKYLINE STORAGE VECTOR
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION S(NOCOEF), C(NDFREE), D(NDFREE),
     1          IDIAG(NDFREE)
C     NDFREE = TOTAL NUMBER OF SYSTEM DOF
C     NOCOEF = IDIAG(NDFREE) = NO OF COEFFS IN MATRIX S
C     IDIAG(I) = LOCATION OF DIAGONAL OF EQ I
C     S = FACTOR OF SYS SQ MATRIX, FROM SKYFAC
C     C = SYSTEM COLUMN MATRIX
C     D = SYSTEM DEGREES OF FREEDOM (RETURNED)
C     DOT = DOT PROD OF 2 VECTORS, FUNCTION PROG
      ZERO = 0.0
      if (zero.eq.zero) stop 'fatal logic if height=1'
C     FORWARD SUBSTITUTION
      D(1) = C(1)
      DO 100  I = 2,NDFREE
      IOFF = IDIAG(I) - IDIAG(I-1) - 1
      IF ( IOFF.LT.1 )  GO TO 100
      ITOP = I - IOFF
      IS = IDIAG(I-1) + 1
      D(I) = C(I) - DOT(IOFF,S(IS),D(ITOP))
 100  CONTINUE
C     BACK SUBSTITUTION
      DO 200  I = 1,NDFREE
      IF ( S(IDIAG(I)).NE.ZERO )  D(I)=D(I)/S(IDIAG(I))
 200  CONTINUE
      NDFM1 = NDFREE - 1
      DO 300  K = 1,NDFM1
      I = NDFREE - K + 1
      IOFF = IDIAG(I) - IDIAG(I-1) - 1
      ITOP = I - IOFF
      JSTART = ITOP
      JSTOP = I - 1
      IF ( JSTART.GT.JSTOP )  GO TO 300
      JD = IDIAG(I-1) - ITOP + 1
      DI = D(I)
      IF ( DI.EQ.ZERO )  GO TO 250
      DO 250  J = JSTART,JSTOP
      D(J) = D(J) - DI*S(J+JD)
 250  CONTINUE
 300  CONTINUE
      RETURN
      END
      SUBROUTINE  SKYSOLVE (A, B, IDIAG, NEQ, FACT, BACK, NOCOEF)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C        PERFORM  A =(U)T*D*U FACTORIZATION AND/OR BACKSUBSTITUTION
C        OF SYMMETRIC POSITIVE DEFINITE SYSTEM OF EQUATIONS
C                      A*X = B
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     A(NA)      = UPPER TRIANGULAR COEFFICIENT MATRIX STORED IN
C                  COLUMN FORM (HOLDS D & U ON EXIT)
C     B(NEQ)     = RIGHT SIDE VECTOR (HOLDS X ON EXIT)
C     IDIAG(NEQ) = ADDRESSES OF DIAGONAL TERMS IN A(NA)
C     NEQ        = NUMBER OF EQUATIONS
C     FACT       = .TRUE. , FACTOR A(NA)
C                  .FALSE. , DO NOT FACTOR A(NA)
C     BACK       = .TRUE. , FORWARD REDUCE B(NEQ) & BACKSUBSTITUTE
C                  .FALSE. , DO NOT FORWARD REDUCE & BACKSUBSTITUTE
C
CDP   IMPLICIT REAL*8  (A-H,O-Z)
      LOGICAL    FACT, BACK
      DIMENSION  A(nocoef), B(neq), IDIAG(neq)
      PARAMETER  ( ZERO = 0.D0 )
C
C.... FACTOR A,  REDUCE B
C
      JR = 0
      DO 600 J = 1, NEQ
        JD = IDIAG(J)
        JH = JD - JR
        IS = J - JH + 2
        IF ( JH-2 )  600, 300, 100
 100      IF ( .NOT. FACT ) GO TO 500
            IE = J - 1
            K  = JR + 2
            ID = IDIAG(IS - 1)
C
C.... REDUCE ALL EQUATIONS EXCEPT DIAGONAL
C
            DO 200 I = IS, IE
              IR = ID
              ID = IDIAG(I)
              IH = MIN0(ID-IR-1, I-IS+1)
              IF ( IH .GT. 0 ) 
     1          A(K) = A(K) - DOT(IH, A(K-IH), A(ID-IH))
200        K  = K + 1
C
C.... REDUCE DIAGONAL TERM
C
  300     IF ( .NOT. FACT )  GO TO 500
            IR = JR + 1
            IE = JD - 1
            K  = J - JD
            DO 400 I = IR, IE
              ID = IDIAG(K+I)
              IF ( A(ID) .EQ. ZERO ) GO TO 400
                D     = A(I)
                A(I)  = A(I)/A(ID)
                A(JD) = A(JD) - D*A(I)
400        CONTINUE
C
C.... REDUCE RHS
C
500       IF ( BACK ) B(J) = B(J) - DOT(JH-1, A(JR+1), B(IS-1))
600     JR = JD
        IF ( .NOT. BACK )  RETURN
C
C.... DIVIDE BY DIAGONAL PIVOTS
C
        DO 700 I = 1, NEQ
          ID = IDIAG(I)
          IF ( A(ID) .NE. ZERO )  B(I) = B(I)/A(ID)
  700   CONTINUE
C
C.... BACKSUBSTITUTE
C
        J  = NEQ
        JD = IDIAG(J)
800     D  = B(J)
        J  = J - 1
        IF ( J .LE. 0 )  RETURN
          JR = IDIAG(J)
          IF ( JD-JR .LE. 1 )  GO TO 1000
            IS = J - JD + JR + 2
            K  = JR - IS + 1
            DO 900 I = IS, J
900         B(I) = B(I) - A(I+K)*D
1000      JD   = JR
        GO TO 800
      END
      SUBROUTINE  SKYSTR (NOCOEF, NDFREE, NELFRE, INDEX, 
     1                    IDIAG, S, SS)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C       STORE ELEMENT SQUARE MATRIX TO SYSTEM SQUARE
C        MATRIX STORED IN SYMMETRIC SKYLINE MODE
C     * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  SS(NOCOEF), S(NELFRE,NELFRE),
     1           INDEX(NELFRE), IDIAG(NDFREE)
C     NOCOEF   = NO COEFF IN SQ MATRIX = IDIAG(NDFREE)
C     NDFREE   = TOTAL NO OF DOF IN SYSTEM
C     NELFRE   = NUMBER OF ELEMENT DEGREES OF FREEDOM
C     INDEX(I) = SYS DOF NO OF ELEMENT DOF I
C     IDIAG(I) = LOCATION OF DIAGONAL OF I-TH EQ
C     S        = ELEMENT SQUARE MATRIX
C     SS       = SYS SQ MATRIX IN SKYLINE VECTOR MODE
C
C      LOOP OVER ELEMENT COEFFICIENTS
      DO 20  J = 1, NELFRE
        NDXJ = INDEX(J)
C        ALLOW FOR OMITTED NODES
        IF ( NDXJ .GT. 0 )  THEN    
          JTEMP = IDIAG(NDXJ) - NDXJ
          DO 10  I = 1, NELFRE
            NDXI = INDEX(I)
            IF ( NDXI .LE. NDXJ .AND. NDXI .GT. 0 ) THEN
C              FIND SYSTEM COEFF IN VECTOR S
              NDXV = JTEMP + NDXI
C             NDXV = IDIAG(AMAX0(NDXI,NDXJ)) 
C                  - IABS(NDXJ-NDXI)
              SS(NDXV) = SS(NDXV) + S(I,J)
            ENDIF
 10       CONTINUE
        ENDIF
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  SKYSUB (NDFREE, IDIAG, I, J, IJV)
C     * * * * * * * * * * * * * * * * * * * * * * *
C     CONVERT (I,J) FULL SYMMETRIC MATRIX SUBSCRIPTS
C     TO IJV SUBSCRIPT OF VECTOR SKYLINE STORAGE MODE
C     * * * * * * * * * * * * * * * * * * * * * * *
C     ASSUMING SYMM EQS, COLS STORED FROM TOP DOWN
      DIMENSION IDIAG(NDFREE)
C     NDFREE   = TOTAL NO OF SYSTEM EQUATIONS
C     IDIAG(I) = LOCATION OF DIAG OF I-TH EQ
      ID  = MAX0 (I,J)
      IJV = IDIAG(ID) - IABS(I-J)
      RETURN
      END
      SUBROUTINE  SKYTAL (NDFREE, IDIAG, J, JTOP,  JBOT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        FIND THE TOP AS WELL AS THE (MAXIMUM) BOTTOM 
C                INDEX OF THE SKYLINE OF COL "J" 
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     ASSUMING SYMM EQS, COLS STORED FROM TOP DOWN
      DIMENSION  IDIAG(NDFREE)
C     JBOT     = LAST NON-ZERO TERM LOCATION IN COLUMN J
C     JTOP     = TOP NON-ZERO TERM LOCATION IN COLUMN J
C     NDFREE   = TOTAL NO OF SYSTEM EQUATIONS
C     IDIAG(I) = LOCATION OF DIAG OF I-TH EQ
C
C      FINDING JTOP
      IF ( J .GT. 1 ) THEN
        JTOP = J - ( IDIAG(J) - IDIAG(J-1) ) + 1
      ELSE
        JTOP = 1
      ENDIF
C      FINDING JBOT
      JBOT = J
      DO 10 I = J+1 , NDFREE
        MINI = I - ( IDIAG(I) - IDIAG(I-1) ) + 1
        IF ( MINI .LE. J )  JBOT = I
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  SOLVE (NDFREE, IBW, S, P, D)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     FOWARD AND BACK SUBSTITUTION OF SYSTEM EQUATIONS
C     PART TWO OF CHOLESKY-GAUSSIAN SOLUTION
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  S(NDFREE,IBW), P(NDFREE), D(NDFREE)
C     NDFREE = MAX. DEGREES OF FREEDOM IN SYSTEM
C     IBW    = MAXIMUM HALF BANDWIDTH OF THE SYSTEM
C     S      = FACTORED SYS SQ MATRIX FROM SUBR FACTOR
C     D      = SYSTEM DEGREES OF FREEDOM TO BE DETERMINED
C     P      = SYSTEM COLUMN MATRIX (KNOWN)
      D(1) = P(1) / S(1,1)
C---  FOWARD SUBSTITUTION
      DO 20  I = 2,NDFREE
        II = I + 1
        J = II - IBW
        IF(II .LE. IBW ) J = 1
        IK = I - 1
        SUM = 0.0
        DO 10 K = J,IK
          KK = II - K
 10     SUM = SUM + S(K,KK)*S(K,1)*D(K)
 20   D(I) = ( P(I) - SUM ) / S(I,1)
C---  BACK SUBSTITUTION
      DO 40  NN = 2,NDFREE
        I = NDFREE + 1 - NN
        LL = I - 1
        J = LL + IBW
        IF ( J.GT.NDFREE )  J = NDFREE
        L = I + 1
        SUM = 0.0
        DO 30 K = L,J
          KK = K - LL
 30     SUM = SUM + S(I,KK)*D(K)
 40   D(I) = D(I) - SUM
      RETURN
      END
      FUNCTION  START (IG, NSPACE, COORD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     DEFINE STARTING VALUE OF PARAMETER IG IN TERMS OF
C     COORDINATES OF THE NODE  (FOR ITERATIVE SOLUTIONS)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C        A PROBLEM DEPENDENT ROUTINE
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  COORD(1,NSPACE)
C     NSPACE = DIMENSION OF SPACE
C     COORD  = SPATIAL COORDINATE ARRAY OF NODE
C     ....................................................
C     ** PROBLEM DEPENDENT START STATEMENTS FOLLOW **
C     ....................................................
C     APPLICATION: LEAST SQ. SOL. OF 2YY''-Y'Y'+4YY=0
C-->   STRAIGHT LINE FIT THROUGH TWO BOUNDARY VALUES
      X     = COORD(1,1)
      START = 0.7162D0*X - 0.125D0
      IF ( IG .EQ. 2 )  START = 0.7162D0
      RETURN
      END
      SUBROUTINE  STORCL (NDFREE,NELFRE,INDEX,C,CC)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     STORE ELEMENT COLUMN MATRIX IN SYSTEM COLUMN MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  C(NELFRE), CC(NDFREE), INDEX(NELFRE)
C     INDEX  = SYSTEM DOF NOS OF THE ELEMENT DOF
C     C      = ELEMENT COLUMN MATRIX
C     CC     = SYSTEM COLUMN MATRIX
C     NDFREE = NO DEGREES OF FREEDOM IN THE SYSTEM
C     NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT
      DO 10 I = 1,NELFRE
        J = INDEX(I)
        IF ( J .GT. 0 )  CC(J) = CC(J) + C(I)
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  STORSQ (NDFREE, IBW, NELFRE, INDEX, S, SS)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     ADD ELEMENT SQUARE MATRIX TO UPPER HALF BANDWIDTH
C     OF THE SYMMETRIC SYSTEM SQUARE MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  S(NELFRE,NELFRE), SS(NDFREE,IBW),
     1           INDEX(NELFRE)
C     INDEX  = SYSTEM DOF NOS OF THE ELEMENT DOF
C     S      = SQUARE ELEMENT MATRIX
C     SS     = SQUARE SYSTEM MATRIX
C     NDFREE = DEGREES OF FREEDOM IN THE SYSTEM
C     IBW    = HALF BAND WIDTH INCLUDING THE DIAGONAL
C     NELFRE = NUMBER OF PARAMETERS (DOF) PER ELEMENT
C     I,J    = ROW AND COLUMN POSITIONS IN THE
C              UNPACKED SYSTEM MATRIX, RESPECTIVELY
C     JJ     = COLUMN POSITION IN PACKED SYSTEM MATRIX
      DO 20 L = 1,NELFRE
        I = INDEX(L)
C        ALLOW FOR OMITTED NODES
        IF ( I .GT. 0 )  THEN
          DO 10 K = 1,NELFRE
            J = INDEX(K)
            IF ( J .GT. 0 )  THEN
C            STORE UPPER BAND ONLY
              IF ( I .LE. J )  THEN
                JJ       = J - I + 1
                SS(I,JJ) = SS(I,JJ) + S(L,K)
              ENDIF
            ENDIF
 10       CONTINUE
        ENDIF
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  STRFUL (NDFREE, NELFRE, S, SS, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     STORE ELEMENT SQ MATRIX IN FULL SYSTEM SQ MATRIX
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  S(NELFRE,NELFRE), SS(NDFREE,NDFREE),
     1           INDEX(NELFRE)
C     NELFRE = NO DEGREES OF FREEDOM PER ELEMENT
C     NDFREE = TOTAL NO OF SYSTEM DEGREES OF FREEDOM
C     SS     = FULL SYSTEM SQUARE MATRIX
C     S      = FULL ELEMENT SQUARE MATRIX
C     INDEX  = SYSTEM DOF NOS OF ELEMENT PARAMETERS
      DO 20  I = 1,NELFRE
        II = INDEX(I)
        IF ( II .GT. 0 )  THEN    
          DO 10  J = 1,NELFRE
            JJ = INDEX(J)
            IF ( JJ .GT. 0 ) THEN
              SS(II,JJ) = SS(II,JJ) + S(I,J)
            ENDIF
   10     CONTINUE
        ENDIF
   20 CONTINUE
      RETURN
      END
      SUBROUTINE  SUMIN  (NDFREE, M, NG, CC, TOTAL)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C          SUM INPUT VALUES IN FORCING VECTOR, CC
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( NCRD = 5, NPRT = 6 )
      DIMENSION  CC(NDFREE), TOTAL(NG)
C     NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM
C     NG     = NUMBER OF PARAMETERS PER NODE
C     CC     = SYSTEM EQUATIONS COLUMN MATRIX
C     M      = TOTAL NUMBER OF NODES IN THE SYSTEM
      DO 5  I = 1, NG
 5    TOTAL(I) = 0.0
      WRITE (6,5030)
 5030 FORMAT ( /, '*** INPUT SOURCE RESULTANTS ***',/,
     1            'DOF       SUM')
      DO 20  I = 1, M
        DO 30  J = 1, NG
          IJEQ = NG*(I-1) + J
   30   TOTAL(J) = TOTAL(J) + CC(IJEQ)
   20 CONTINUE
      DO 40  J = 1, NG
   40 WRITE (6,5040) J, TOTAL(J)
 5040 FORMAT ( I3, 2X, 1PE12.4 )
      RETURN
      END
      SUBROUTINE  SYMINV (A, N)
C     * * * * * * * * * * * * * * * * * * * * * * *
C-->  INVERT SYMMETRIC MATRIX A(N,N)
C     * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION A(N,N)
      DO 40  K = 1,N
        D = A(K,K)
        IF ( D .EQ. 0.0 ) STOP 'ZERO PIVOT IN SYMINV'
        DO 10  J = 1, N
   10   A(K,J) = -A(K,J)/D
        DO 30  I = 1, N
          IF ( I .NE. K )  THEN
            DO 20  J = 1, N
              IF ( J .NE. K ) 
     1        A(I,J) = A(I,J) + A(I,K)*A(K,J) 
   20       CONTINUE
          ENDIF
   30   A(I,K) = A(I,K)/D
   40 A(K,K) = 1.0/D
      RETURN
      END
      SUBROUTINE  SYMRUL (NIP, QPT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     SYMMETRICAL QUADRATURE RULES FOR TRIANGLES
C                  IN UNIT COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER  ( MAX = 13 )
      DIMENSION QPT(2,0:NIP), WT(0:NIP)
C     NIP = NUMBER OF SYMMETRIC POINTS
C     QPT = UNIT COORDINATES OF QUADRATURE POINTS
C     WT  = WEIGHTS AT POINTS
      NQP = NIP
      IF ( NQP .GT. MAX )  THEN
        NQP = MAX
        WRITE (6,*) 'WARNING SYMRUL SET NQP =', MAX
      ENDIF
      IF ( NQP .LT. 1 ) STOP 'ERROR IN SYMRUL, STOP'
      GOTO (1,20,3,4,20,6,7,20,20,20,20,12,13,20), NQP
C-->  ONE POINT RULE
    1 WT(1) = 0.500000000
      QPT(1,1) = 1.0/3.0
      QPT(2,1) = 1.0/3.0
      RETURN
C-->  THREE POINT INTERIOR RULE
    3 WT(1) = 0.16666667
      WT(2) = WT(1)
      WT(3) = WT(1)
      QPT(1,1) = 0.16666667
      QPT(2,1) = 0.16666667
      QPT(1,2) = 0.66666667
      QPT(2,2) = 0.16666667
      QPT(1,3) = 0.16666667
      QPT(2,3) = 0.66666667
      RETURN
C-->  FOUR POINT INTERIOR (ALL) RULE
    4 WT(1) = -27.0/96.0
      WT(2) = 25.0/96.0
      WT(3) = WT(2)
      WT(4) = WT(2)
      QPT(1,1) = 1.0/3.0
      QPT(2,1) = 1.0/3.0
      QPT(1,2) = 0.20
      QPT(2,2) = 0.20
      QPT(1,3) = 0.20
      QPT(2,3) = 0.60
      QPT(1,4) = 0.60
      QPT(2,4) = 0.20
      RETURN
C-->  SIX POINT RULE
    6 WT(1) = 0.054975872
      WT(2) = WT(1)
      WT(3) = WT(1)
      WT(4) = 0.111690795
      WT(5) = WT(4)
      WT(6) = WT(4)
      QPT(1,1) = 0.81684757
      QPT(2,1) = 0.091576214
      QPT(1,2) = 0.091576214
      QPT(2,2) = 0.091576214
      QPT(1,3) = 0.091576214
      QPT(2,3) = 0.81684757
      QPT(1,4) = 0.10810302
      QPT(2,4) = 0.44594849
      QPT(1,5) = 0.44594849
      QPT(2,5) = 0.44594849
      QPT(1,6) = 0.44594849
      QPT(2,6) = 0.10810302
      RETURN
C-->  SEVEN POINT INTERIOR RULE
    7 WT(1) = 0.06296959
      WT(2) = 0.06619708
      WT(3) = 0.06296959
      WT(4) = 0.06619708
      WT(5) = 0.06296959
      WT(6) = 0.06619708
      WT(7) = 0.11250000
      QPT(1,1) = 0.10128651
      QPT(2,1) = 0.10128651
      QPT(1,2) = 0.47014206
      QPT(2,2) = 0.05971587
      QPT(1,3) = 0.79742699
      QPT(2,3) = 0.10128651
      QPT(1,4) = 0.47014206
      QPT(2,4) = 0.47014206
      QPT(1,5) = 0.10128651
      QPT(2,5) = 0.79742699
      QPT(1,6) = 0.05971587
      QPT(2,6) = 0.47014206
      QPT(1,7) = 1.0/3.0
      QPT(2,7) = 1.0/3.0
      RETURN
C-->  TWELVE POINT RULE
   12 WT(1) = 0.025422453
      WT(2) = WT(1)
      WT(3) = WT(1)
      WT(4) = 0.058393138
      WT(5) = WT(4)
      WT(6) = WT(4)
      WT(7) = 0.041425538
      WT(8) = WT(7)
      WT(9) = WT(7)
      WT(10) = WT(7)
      WT(11) = WT(7)
      WT(12) = WT(7)
      QPT(1,1) = 0.87382197
      QPT(2,1) = 0.063089014
      QPT(1,2) = 0.063089014
      QPT(2,2) = 0.063089014
      QPT(1,3) = 0.063089014
      QPT(2,3) = 0.87382197
      QPT(1,4) = 0.50142651
      QPT(2,4) = 0.24928675
      QPT(1,5) = 0.24928675
      QPT(2,5) = 0.24928675
      QPT(1,6) = 0.24928675
      QPT(2,6) = 0.50142651
      QPT(1,7) = 0.63650250
      QPT(2,7) = 0.31035245
      QPT(1,8) = 0.31035245
      QPT(2,8) = 0.053145050
      QPT(1,9) = 0.053145050
      QPT(2,9) = 0.63650250
      QPT(1,10) = 0.63650250
      QPT(2,10) = 0.053145050
      QPT(1,11) = 0.31035245
      QPT(2,11) = 0.63650250
      QPT(1,12) = 0.053145050
      QPT(2,12) = 0.31035245
      RETURN
C-->  THIRTEEN POINT RULE
   13 WT(1) = -0.074785022
      WT(2) = 0.087807629
      WT(3) = WT(2)
      WT(4) = WT(2)
      WT(5) = 0.026673618
      WT(6) = WT(5)
      WT(7) = WT(5)
      WT(8) = 0.038556880
      WT(9) = WT(8)
      WT(10) = WT(8)
      WT(11) = WT(8)
      WT(12) = WT(8)
      WT(13) = WT(8)
      QPT(1,1) = 1.0/3.0
      QPT(2,1) = 1.0/3.0
      QPT(1,2) = 0.47930807
      QPT(2,2) = 0.26034597
      QPT(1,3) = 0.26034597
      QPT(2,3) = 0.26034597
      QPT(1,4) = 0.26034597
      QPT(2,4) = 0.47930807
      QPT(1,5) = 0.86973979
      QPT(2,5) = 0.065130103
      QPT(1,6) = 0.065130103
      QPT(2,6) = 0.065130103
      QPT(1,7) = 0.065130103
      QPT(2,7) = 0.86973979
      QPT(1,8) = 0.63844419
      QPT(2,8) = 0.31286550
      QPT(1,9) = 0.31286550
      QPT(2,9) = 0.048690315
      QPT(1,10) = 0.048690315
      QPT(2,10) = 0.63844419
      QPT(1,11) = 0.63844419
      QPT(2,11) = 0.048690315
      QPT(1,12) = 0.31286550
      QPT(2,12) = 0.63844419
      QPT(1,13) = 0.048690315
      QPT(2,13) = 0.31286550
      RETURN
C     UNTABULATED DATA
 20   WRITE (6,*) 'DATA NOT IN SYMRUL, USED NQP  = 13'
      NQP = MAX
      GO TO 13 
 30   RETURN
      END
      SUBROUTINE  SYSBAN (NE,N,NG,IBW,NODES,LNODE,LMAX)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C        DETERMINE UPPER HALF BAND WIDTH OF SYSTEM
C     * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  NODES(NE,N), LNODE(N)
C     NE    = NUMBER OF ELEMENTS IN SYSTEM
C     N     = NUMBER OF NODES PER ELEMENT
C     NG    = NUMBER OF PARAMETERS (DOF) PER ELEMENT
C     IBW   = MAXIMUM HALF BANDWIDTH = LBW MAX
C     NODES = NODAL INCIDENCES OF ALL ELEMENTS
C     LNODE = ELEMENT INCIDENCES LIST
C     LBW   = ELEMENT HALF BANDWIDTH
C     LMAX  = LAST ELEMENT CAUSING LBW
      LMAX = 1
      IBW  = 1
      DO 10  I = 1, NE
        CALL  LNODES (I,NE,N,NODES,LNODE)
        CALL  ELBAND (N,NG,LBW,LNODE)
        IF ( LBW .GT. IBW )  THEN
          IBW  = LBW
          LMAX = I
        ENDIF
 10   CONTINUE
      RETURN
      END
      program T3EXACT
c
c     exact unit coordinate integration on
c     triangles with constant jacobian:
c     area integral r^m s^n dA = A/k
c
      parameter ( MAX = 8, LIMIT = MAX*2 + 2 )
      implicit real*16 (a-h,o-z)
      dimension  fact(0:LIMIT), num(0:MAX,0:MAX) 
c      fact = array of factorial values
c      num  = k values for all m,n
      data fact / 1.d0, 1.d0, 2.d0, 6.d0, 24.d0,
     1            120.d0, 720.d0, 5040.d0, 40320.d0,
     2            362880.d0, 3628800.d0, 8*0.d0 /
c      initialize factorials
      do 5  i = 0,LIMIT
        if ( i .gt. 10 ) fact(i) = i*fact(i-1)
  5   write(6,*) i, fact(i)
c      compute integrals
      do 10  m = 0,MAX
        do 20  n = 0,MAX
          j = 2+m+n
          a = fact(j)/fact(m)/fact(n)*0.5d0
          k = a
          num(m,n) = k
          write(6,*) m,n,k
  20    continue
  10  continue
      call iprint(num,MAX+1,MAX+1)
      stop
      end
      SUBROUTINE  IPRINT (M, NR, NC)
C     * * * * * * * * * * * * * * * * * * * * * * *
C        PRINTING OF AN INTEGER ARRAY M(NR,NC)
C     * * * * * * * * * * * * * * * * * * * * * * *
      PARAMETER ( NPRT = 6, MAX = 10 )
      DIMENSION  M(1), NCOL(MAX)
      DO 30  J = 1,NC,MAX
        JL1 = J - 1
        MAXCOL = 1
        K = NC - JL1
        MAXCOL = MIN0 (K,MAX)
        MXCLL1 = MAXCOL - 1
        DO 10  L = 1,MAXCOL
   10   NCOL(L) = L + JL1
        WRITE (NPRT,5000)  ( NCOL(N),N=1,MAXCOL )
 5000   FORMAT ('ROW/COL',I7, 9I10 )
        DO 20  N = 1,NR
          NL = N + (J-1)*NR
          NH = NL + MXCLL1*NR
          WRITE (NPRT,5010)  N,( M(I),I=NL,NH,NR )
 5010     FORMAT ( I4, 10I10 )
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  TANVEC (N, NPARM, NSPACE, DELTA, 
     1                    COORD, GRAD)
C     * * * * * * * * * * * * * * * * * * * * * * * * *
C      CALCULATE THE TANGENT VECTORS AT A LOCAL POINT
C       ON A PARAMETRIC CURVE OR PARAMETRIC SURFACE
C     * * * * * * * * * * * * * * * * * * * * * * * * * 
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  DELTA(NPARM,N), COORD(N,NSPACE),
     1           GRAD(NPARM,NSPACE)
C     N      = NUMBER OF NODES PER ELEMENT
C     NPARM  = NUMBER OF PARAMETRIC DIMENSIONS <= NSPACE
C     NSPACE = DIMENSION OF PHYSICAL SPACE
C     DELTA  = LOCAL  DERIVATIVES OF N INTERPOLATION
C              FUNCTIONS AT POINT OF INTEREST.
C     COORD  = SPATIAL COORDINATES OF ELEMENT'S NODES
C     GRAD   = TANGENT MATRIX = DELTA*COORD
C              ROW 1 IS DR/DU, 2 DR/DV, 3 DR/DW
C              FOR NPARM = NSPACE, GRAD = JACOBIAN
      DO 30  I = 1, NPARM
        DO 20  J = 1, NSPACE
          SUM = 0.0
          DO 10  K = 1, N
            SUM = SUM + DELTA(I,K)*COORD(K,J)
 10       CONTINUE
        GRAD(I,J) = SUM
 20     CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE  TETRUL (NIP, QPT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * *
C       UNIT COORD QUADRATURE RULES FOR TETRAHEDRA
C     * * * * * * * * * * * * * * * * * * * * * * * *
C     REF: M. GELLERT, COMM APP NUM METH, 7,487,1991
      DOUBLE PRECISION A, B, C, D, E, F, G, H,
     1                 ZERO, HALF, THIRD, SIXTH
      PARAMETER ( MAX = 11 )
      PARAMETER ( A = 0.5854101966249685D0, 
     1            B = 0.1381966011250105D0,
     2            C = 0.5684305841968444D0,
     3            D = 0.1438564719343852D0,
     4            F = 0.0214899534130631D0,
     5            G = 0.3994035761667992D0,
     6            H = 0.1005964238332008D0 )
      PARAMETER ( ZERO = 0.0D0, THIRD = 1.0D0/3.0D0,  
     1            HALF = 0.5D0, SIXTH = 1.0D0/6.0D0  )
      DIMENSION  QPT(3,0:NIP), WT(0:NIP)
C     NIP = NUMBER OF INTEGRATION POINTS
C     QPT = LOCAL COORD OF QUADRATURE POINT
C     WT  = WEIGHT FOR QUADRATURE POINT
      N = NIP
      IF ( N .LT. 1 .OR. N .GT. MAX )  THEN
        N = MAX
        WRITE (6,*) ' WARNING: TETRUL SET N =', MAX
      ENDIF
      IF ( N .EQ. 1 )  THEN   
C      1-PT RULE, DEGREE OF PRECISION = 1
        WT(1)    = 1.0D0/6.0D0
        QPT(1,1) = 0.25D0
        QPT(2,1) = 0.25D0
        QPT(3,1) = 0.25D0
        RETURN
      ELSEIF ( N .EQ. 4 )  THEN   
C      4-PT RULE, DEGREE OF PRECISION = 2
        WT(1)    = 1.0D0/24.0D0
        WT(2)    = 1.0D0/24.0D0
        WT(3)    = 1.0D0/24.0D0
        WT(4)    = 1.0D0/24.0D0
        QPT(1,1) = A
        QPT(2,1) = B
        QPT(3,1) = B
        QPT(1,2) = B
        QPT(2,2) = A
        QPT(3,2) = B
        QPT(1,3) = B
        QPT(2,3) = B
        QPT(3,3) = A
        QPT(1,4) = B
        QPT(2,4) = B
        QPT(3,4) = B
        RETURN
      ELSEIF ( N .EQ. 5 )  THEN   
C      5-PT RULE, DEGREE OF PRECISION = 3
        WT(1)    = -4.0D0/30.
        WT(2)    =  9.0D0/120.
        WT(3)    =  9.0D0/120.
        WT(4)    =  9.0D0/120. 
        WT(5)    =  9.0D0/120.
        QPT(1,1) = 0.25D0
        QPT(2,1) = 0.25D0
        QPT(3,1) = 0.25D0
        QPT(1,2) = THIRD
        QPT(2,2) = SIXTH
        QPT(3,2) = SIXTH
        QPT(1,3) = SIXTH
        QPT(2,3) = THIRD
        QPT(3,3) = SIXTH
        QPT(1,4) = SIXTH
        QPT(2,4) = SIXTH
        QPT(3,4) = THIRD
        QPT(1,5) = SIXTH
        QPT(2,5) = SIXTH
        QPT(3,5) = SIXTH
        RETURN
      ELSEIF ( N .EQ. 10 )  THEN   
C      10-PT RULE, DEGREE OF PRECISION = 3
        WT(1)    = E/6.0D0
        WT(2)    = E/6.0D0
        WT(3)    = E/6.0D0
        WT(4)    = E/6.0D0
        WT(5)    = F/6.0D0
        WT(6)    = F/6.0D0
        WT(7)    = F/6.0D0
        WT(8)    = F/6.0D0
        WT(9)    = F/6.0D0
        WT(10)   = F/6.0D0
        QPT(1,1) = C
        QPT(2,1) = D
        QPT(3,1) = D
        QPT(1,2) = D
        QPT(2,2) = C
        QPT(3,2) = D
        QPT(1,3) = D
        QPT(2,3) = D
        QPT(3,3) = C
        QPT(1,4) = D
        QPT(2,4) = D
        QPT(3,4) = D
        QPT(1,5) = HALF
        QPT(2,5) = HALF
        QPT(3,5) = ZERO
        QPT(1,6) = HALF
        QPT(2,6) = ZERO
        QPT(3,6) = HALF
        QPT(1,7) = HALF
        QPT(2,7) = ZERO
        QPT(3,7) = ZERO
        QPT(1,8) = ZERO
        QPT(2,8) = HALF
        QPT(3,8) = HALF
        QPT(1,9) = ZERO
        QPT(2,9) = HALF
        QPT(3,9) = ZERO
        QPT(1,10) = ZERO
        QPT(2,10) = ZERO
        QPT(3,10) = HALF
      ELSEIF ( N .EQ. 11 )  THEN   
C      11-PT RULE, DEGREE OF PRECISION = 4
        WT(1)    = 343.0D0/45000.0D0
        WT(2)    = 343.0D0/45000.0D0
        WT(3)    = 343.0D0/45000.0D0
        WT(4)    = 343.0D0/45000.0D0
        WT(5)    = 56.0D0/2250.0D0
        WT(6)    = 56.0D0/2250.0D0
        WT(7)    = 56.0D0/2250.0D0
        WT(8)    = 56.0D0/2250.0D0
        WT(9)    = 56.0D0/2250.0D0
        WT(10)   = 56.0D0/2250.0D0
        WT(11)   = -74.0D0/5625.0D0 
        QPT(1,1) = 11.0D0/14.0D0
        QPT(2,1) =  1.0D0/14.0D0
        QPT(3,1) =  1.0D0/14.0D0
        QPT(1,2) =  1.0D0/14.0D0
        QPT(2,2) = 11.0D0/14.0D0
        QPT(3,2) =  1.0D0/14.0D0
        QPT(1,3) =  1.0D0/14.0D0
        QPT(2,3) =  1.0D0/14.0D0
        QPT(3,3) = 11.0D0/14.0D0
        QPT(1,4) =  1.0D0/14.0D0
        QPT(2,4) =  1.0D0/14.0D0
        QPT(3,4) =  1.0D0/14.0D0
        QPT(1,5) = G
        QPT(2,5) = G
        QPT(3,5) = H
        QPT(1,6) = G
        QPT(2,6) = H
        QPT(3,6) = G
        QPT(1,7) = G
        QPT(2,7) = H
        QPT(3,7) = H
        QPT(1,8) = H
        QPT(2,8) = G
        QPT(3,8) = G
        QPT(1,9) = H
        QPT(2,9) = G
        QPT(3,9) = H
        QPT(1,10) = H
        QPT(2,10) = H
        QPT(3,10) = G
        QPT(1,11) = 0.25D0
        QPT(2,11) = 0.25D0
        QPT(3,11) = 0.25D0
        RETURN
      ENDIF
      RETURN
      END
      SUBROUTINE  TRINTG (M,N,COORD,VALUE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     7 POINT QUADRATURE INTEGRATION OF (X**M)(Y**N)(DA)
C          ON AN ARBITRARY TRIANGLE (AREA COORD)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  COORD(3,2), A1(7), A2(7), A3(7), WT(7)
C     REFER  MEEK,  MATRIX STRUCTURAL ANALYSIS
      DATA  WT  /0.22500000,3*0.13239415,3*0.12593918/
      DATA  A1  /0.33333333,2*0.47014206,0.05971587,
     1           0.10128651,0.79742699,0.10128651/
      DATA  A2  /0.33333333,0.05971587,2*0.47014206,
     1           2*0.1028651,0.79742699/
      DATA  A3  /0.33333333,0.470142061,0.05971587,
     1           0.47014206,0.79742699,2*0.10128651/
      VALUE = 0.0
      X1 = COORD(1,1)
      X2 = COORD(2,1)
      X3 = COORD(3,1)
      Y1 = COORD(1,2)
      Y2 = COORD(2,2)
      Y3 = COORD(3,2)
      DO 10  I = 1,7
      XP = X1*A1(I) + X2*A2(I) + X3*A3(I)
      YP = Y1*A1(I) + Y2*A2(I) + Y3*A3(I)
 10   VALUE = VALUE + XP**M * YP**N * WT(I)
      AREA = 0.5*( X1*(Y2-Y3) + X2*(Y3-Y1) +X3*(Y1-Y2) )
      VALUE = VALUE*AREA
      RETURN
      END
      SUBROUTINE  UNITCO  (N,A,W)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CONVERT GAUSS COEFF FROM NATURAL TO UNIT COORDINATES
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
      DIMENSION  A(N), W(N)
C     A = ABSISSAE, -1 TO 1 ARE 0 TO 1 ON EXIT
C     N = NUMBER OF TABULATED GAUSS OR LOBATTO PTS IN 1-D
C     W = WEIGHTS
      DO 10  I = 1, N
        A(I) = (A(I) + 1.D0)*0.5D0
 10   W(I) = W(I)*0.5D0
      RETURN
      END
      SUBROUTINE  USERQD (NQP, GPT, GWT, NSPACE, PT, WT)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C              USER SUPPLIED QUADRATURE RULE DATA
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * 
      DIMENSION  GPT(0:NQP), GWT(0:NQP), PT(NSPACE,0:NQP), 
     1           WT(0:NQP)
C
C     ......................................................
C     USER SUPPLIED OPTION FOLLOWS
C     ......................................................
C     SPECIAL RULE FOR SINGULARITY ELEMENTS
      CALL RADAU (NQP, PT, WT)
      RETURN
      END

      SUBROUTINE  VECT2D (NTAPE2,XLEN,YLEN,FIRSTX,FIRSTY,DELTAX,
     1                    DELTAY,XLAST,YLAST,SCALIT,SIZE,NE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     CONSTRUCT 2-D VECTOR PLOTS OF VECTORS TABULATED ON NTAPE2
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     XLEN, YLEN     = PLOT LENGTH IN INCHES
C     FIRSTX, FIRSTY = GLOBAL COORDINATES OF PLOT ORIGIN
C     DELTAX, DELTAY = CHANGE IN GLOBAL COORD. PER INCH OF PLOT
C     NE             = NO. ELEMENTS
C     NIP            = NO. PLOT PTS IN ELEMENT
C     SIZE           = SIZE OF SYMBOLS, IN INCHES
      REWIND  NTAPE2
CPLT  CALL AXIS (0.,0.,'X-COORDS',-8,XLEN,0.0,FIRSTX,DELTAX)
CPLT  CALL AXIS (0.,0.,'Y-COORDS', 8,YLEN,90.,FIRSTY,DELTAY)
C     LOOP OVER ELEMENTS
      DO 30  J = 1, NE
        READ (NTAPE2) NIP
C        LOOP OVER VECTOR POINTS
        DO 40  K = 1, NIP
          READ (NTAPE2) X, Y, DX, DY
C          MOVE PEN TO POINT (CONVERT FROM GLOBAL TO INCHES)
          X = (X-FIRSTX)/DELTAX
          Y = (Y-FIRSTY)/DELTAY
C          IS POINT IN REGION OF INTEREST
          IF ( X.LT.FIRSTX .OR. X.GT.XLAST )  GO TO 40
            IF ( Y.LT.FIRSTY .OR. Y.GT.YLAST )  GO TO 40
CPLT          CALL PLOT (X,Y,3)
C             SCALE MAX. COMPONENT TO 1 INCH & FIND ANGLE
             DX = DX/SCALIT
             DY = DY/SCALIT
             ANG = ATAN2(DY,DX)*57.3 - 90.
            X = X + DX
            Y = Y + DY
            VECTOR = SQRT(DX*DX+DY*DY)
C            DRAW LINE AND ARROW
CPLT        CALL SYMBOL (X,Y,SIZE,6,ANG,-2)
   40   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  WRTELM (NE, N, NG, NDFREE, NELFRE, DD, 
     1                    INDEX, NODES, LNODE)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     OUTPUT, BY ELEMS, OF CALCULATED DEGREES OF FREEDOM
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  DD(NDFREE), INDEX(NELFRE), NODES(NE,N),
     1           LNODE(N)
C     NE     = NUMBER OF ELEMENTS IN SYSTEM
C     N      = NUMBER NODES PER ELEMENT
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     NDFREE = NUMBER DEGREES OF FREEDOM IN SYSTEM
C     NELFRE = NUMBER DEGREES OF FREEDOM PER ELEMENT
C     DD     = CALCULATED NODAL PARAMETERS (DOF)
C     INDEX  = SYSTEM DOF NUMBERS FOR ELEMENT PARAMETERS
C     NODES  = NODAL INCIDENCES OF ALL ELEMENTS
C     LNODE  = NODAL INCIDENCES OF AN ELEMENT
      WRITE (NPRT,5000)  NG
 5000 FORMAT ( /, '***  OUTPUT OF RESULTS  ***',/,
     1        'ELEMENT, NODE,'I3,' PARAMETERS')
      DO 20  IE = 1, NE
        CALL LNODES (IE, NE, N, NODES, LNODE)
        DO 10  K = 1, N
          NODE = LNODE(K)
C          ALLOW FOR OMITTED NODES
          IF ( NODE .GT. 0 )  THEN   
            CALL INDXPT (NODE,NG,INDEX)
            WRITE (NPRT,5010) IE, NODE, (DD(INDEX(L)),L=1,NG)
 5010       FORMAT (I5, I8, 2X, (6(1X, 1PE12.5)) )
          ENDIF
 10     CONTINUE
 20   CONTINUE
      RETURN
      END
      SUBROUTINE  WRTPT (M, NG, NDF, NSPACE, X, DD, INDEX)
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
C     OUTPUT, BY NODES, OF CALCULATED DEGREES OF FREEDOM
C     * * * * * * * * * * * * * * * * * * * * * * * * * *
CDP   IMPLICIT REAL*8  (A-H,O-Z)
      PARAMETER ( NPRT = 6 )
      DIMENSION  X(M,NSPACE), DD(NDF), INDEX(NG)
C     M      = NUMBER OF NODES IN SYSTEM
C     NG     = NUMBER OF PARAMETERS (DOF) PER NODE
C     NDF    = NUMBER OF DOF IN THE SYSTEM
C     NSPACE = DIMENSION OF SPACE
C     X      = SYSTEM COORDINATES OF ALL NODES
C     DD     = CALCULATED NODAL PARAMETERS
C     INDEX  = SYSTEM DOF NOS OF PARAMETERS ON A NODE
      WRITE (NPRT,5000) NSPACE, NG
 5000 FORMAT( /, '***  OUTPUT OF RESULTS  ***',/,
     1 'NODE, ',I1,' COORDINATES, ',I2,' PARAMETERS.')
      DO 10  I = 1, M
        CALL  INDXPT (I,NG,INDEX)
        WRITE (NPRT,5010) I, ( X(I,L), L=1,NSPACE ),
     1                       ( DD(INDEX(K)), K=1,NG )
 5010   FORMAT ( I5, (9(1X, 1PE12.5)) )
 10   CONTINUE
      RETURN
      END
      SUBROUTINE  ZEROA (N,A)
C     * * * * * * * * * * * * * *
C       ZERO A REAL ARRAY A(N)
C     * * * * * * * * * * * * * *
CDP   REAL*8 A
      DIMENSION  A(N)
      DO 10  J = 1,N
 10   A(J) = 0.0
      RETURN
      END
      SUBROUTINE  ZEROI (N,I)
C     * * * * * * * * * * * * * * * *
C       ZERO AN INTEGER ARRAY I(N)
C     * * * * * * * * * * * * * * * *
      DIMENSION  I(N)
      DO 10  J = 1,N
 10   I(J) = 0
      RETURN
      END
