Liren Large Software Subsidy 9/09.iso/e/e001/1.ddi/TMP/ADINA22.FOR

Text File | 1991-01-07 | 203.6 KB | 7,604 lines

C *CDC* *DECK MIDEP
C *UNI* )FOR,IS  N.MIDEP,  R.MIDEP
      SUBROUTINE MIDEP
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VMISES/ A1,B1,C1,D1,A2,B2,C2,A3,BM,BET,CEE,
     1                DEPS(4),DEPSP(4),TEPS(4),ALFA(4),HP,FTB,A1I,B1I,
     2                C1I,XCON1,XCON2,MOD,ISR,IST
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
C
      DIMENSION DP(16)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),DP(1))
C
C
      SM=(STRESS(1)+STRESS(2)+STRESS(4))/3.
      SX=STRESS(1)-SM
      SY=STRESS(2)-SM
      SZ=STRESS(4)-SM
      SS=STRESS(3)
C
      IF (MOD.EQ.2) GO TO 5
C
      SX=SX - ALFA(1)
      SY=SY - ALFA(2)
      SZ=SZ - ALFA(4)
      SS=SS - ALFA(3)
C
    5 IF (ITYP2D-1) 10,11,12
   10 WP= SX*DEPS(1) + SY*DEPS(2) + SS*DEPS(3) + SZ*DEPS(4)
      GO TO 15
C
   11 WP= SX*DEPS(1) + SY*DEPS(2) + SS*DEPS(3)
      GO TO 15
C
   12 BETA=BET*SZ
      DP1=B2 - BETA*SX
      DP2=B2 - BETA*SY
      DP3=   - BETA*SS
      DP4=A2 - BETA*SZ
C
      DEPS(4)= (-DP1*DEPS(1)-DP2*DEPS(2)-DP3*DEPS(3))/DP4
      WP= SX*DEPS(1) + SY*DEPS(2) + SS*DEPS(3) + SZ*DEPS(4)
C
   15 BETT=BET
      IF (WP.LT.0.0) BETT=0.
C
C     CALCULATE PLASTIC STRAIN INCREMENTS
C
      XLAMDA=(BETT/(2.*C1))*WP
      DEPSP(1)=XLAMDA*SX
      DEPSP(2)=XLAMDA*SY
      DEPSP(3)=2.0*XLAMDA*SS
      DEPSP(4)=XLAMDA*SZ
C
      BETA=BETT*SX
      DP( 1)=A2 - BETA*SX
      DP( 2)=B2 - BETA*SY
      DP( 3)=   - BETA*SS
      DP( 4)=B2 - BETA*SZ
C
      BETA=BETT*SY
      DP( 5)=DP (2)
      DP( 6)=A2 - BETA*SY
      DP( 7)=   - BETA*SS
      DP( 8)=B2 - BETA*SZ
C
      BETA=BETT*SS
      DP( 9)=DP (3)
      DP(10)=DP (7)
      DP(11)=C2 - BETA*SS
      DP(12)=   - BETA*SZ
C
      IF (ITYP2D.EQ.1) RETURN
C
      DP(13)=DP (4)
      DP(14)=DP (8)
      DP(15)=DP(12)
      DP (16)=A2 - BETT*SZ*SZ
C
      IF (ITYP2D.EQ.0) RETURN
C
C     PLANE STRESS / MODIFY DP MATRIX
C
      DO 120 I=1,3
      A=C(I,4)/C(4,4)
      DO 120 J=I,3
      C(I,J)=C(I,J) - C(4,J)*A
  120 C(J,I) = C(I,J)
      IF (WP.LT.0.0) DEPS(4)=D1 * (DEPS(1)+DEPS(2))
      STRAIN(4)=STRAIN(4) + DEPS(4)
C
C
      RETURN
      END
C *CDC* *DECK HARDM2
C *UNI* )FOR,IS N.HARDM2,R.HARDM2
      SUBROUTINE HARDM2 (PROP,EPSTR,ET)
C
C
C
C     THIS SUBROUTINE CALCULATES THE SLOPE OF THE UNIAXIAL
C     STRESS-STRAIN CURVE CORRESPONDING TO A GIVEN VALUE
C     OF ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
C
C
C        NPR  = NUMBER OF PAIRS OF STRESS-STRAIN VALUES DEFINING THE
C               PLASTIC PORTION OF THE STRESS-STRAIN CURVE
C        NSEG = NUMBER OF SEGMENTS IN THE PLASTIC PORTION OF THE CURVE
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      DIMENSION PROP(1)
      EQUIVALENCE (NPAR(17),NCON)
C
C
      YM=PROP(1)
      NPR=(NCON - 2)/2
      NSEG=NPR - 1
C
      KK=6
      DO 10 J=1,NSEG
      TEPSTR=PROP(KK) - (PROP(KK - 1)/YM)
      IF (EPSTR.LT.TEPSTR) GO TO 20
   10 KK=KK + 2
C
      WRITE (6,2000)
      STOP
C
C     CALCULATE THE HARDENING MODULUS
C
   20 ET=(PROP(KK - 1) - PROP(KK - 3))/(PROP(KK) - PROP(KK - 2))
C
      RETURN
C
 2000 FORMAT (126H   ERROR   ACCUMULATED EFFECTIVE PLASTIC STRAIN IS OUT
     1SIDE THE RANGE OF THE UNIAXIAL STRESS-STRAIN CURVE   (SUBROUTINE H
     2ARDM2))
C
      END
C *CDC* *DECK OVL36
C *CDC*       OVERLAY (ADINA,3,6)
C *CDC* *DECK EL2D10
C *UNI* )FOR,IS  N.EL2D10, R.EL2D10
C *CDC*      PROGRAM EL2D10
C
      SUBROUTINE EL2D10
C
C
C
C     THERMOELASTIC/PLASTIC/CREEP MATERIAL MODEL
C        MODEL = 10  (ISOTROPIC HARDENING, VON MISES YIELD CRITERION)
C        MODEL = 11  (KINEMATIC HARDENING, VON MISES YIELD CRITERION)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /DPR/ ITWO
      COMMON A(1)
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
C
      REAL A
C
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT),(A(1),IA(1)),(NPAR(17),NCON),
     1            (NPAR(7),MXNODS)
C
C
C
C     FOR ADDRESSES N101,N102,..........SEE SUBROUTINE TODMFE
C
C     QUANTITIES STORED FOR EACH INTEGRATION POINT
C
C        STRESS COMPONENTS
C        TOTAL STRAIN COMPONENTS
C        PLASTIC STRAIN COMPONENTS
C        CREEP STRAIN COMPONENTS
C        YIELD STRESS
C        ACCUMULATED INCREMENTS OF EFFECTIVE PLASTIC STRAIN
C        YIELD SURFACE TRANSLATION COMPONENTS
C        ORIGINS FOR O.R.N.L. CYCLIC CREEP
C        TEMPERATURE
C        IPEL AND NORG
C        IPEL = 1 THERMO-ELASTIC AND CREEP BEHAVIOR
C             = 2 THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR
C        NORG = 1 POSITIVE ORIGIN
C             = 2 NEGATIVE ORIGIN
C
C     QUANTITIES STORED FOR EACH ELEMENT
C
C        GLOBAL NODAL POINT NUMBERS
C
C
C
      IDW=33*ITWO
      NPT=NINT*NINT
C
C        1. DETERMINE MATERIAL PROPERTY SET NUMBER
C
      MATP=IA(N107 + NEL - 1)
C
C        2. DETERMINE MATERIAL PROPERTY SET LOCATIONS
C
      NM=N109 + (MATP - 1)*NCON*ITWO
C
C        3. INITIALIZE WORKING ARRAY
C
      IF(IND.NE.0) GO TO 100
      NN=N110+(NEL-1)*(IDW*NPT+MXNODS)
      CALL IEPC2(A(NN),A(NN + IDW*NPT),A(NN),IDW,A(N6A + ITWO),A(NM))
      GO TO 200
C
C        4. DETERMINE LOCATIONS OF VARIABLES IN WORKING ARRAY
C
  100 NN=N110 + (NEL - 1)*(IDW*NPT + MXNODS) + (IPT - 1)*IDW
      NN1=NN
      NN2=NN + 4*ITWO
      NN3=NN + 8*ITWO
      NN4=NN + 12*ITWO
      NN5=NN + 16*ITWO
      NN6=NN + 17*ITWO
      NN7=NN + 18*ITWO
      NN8=NN + 22*ITWO
      NN9=NN + 30*ITWO
      NN10=NN + 31*ITWO
      NN11=NN + 32*ITWO
C
C        5. DETERMINE ELEMENT GLOBAL NODAL POINT NUMBERS LOCATION
C
      KK=N110+(NEL-1)*(IDW*NPT+MXNODS)+IDW*NPT
C
C        6. DETERMINE MIDSIDE NODE ARRAY LOCATION
C
      ND5DIM=MXNODS-4
      LL=N111+(NEL-1)*ND5DIM
C
C        7. CALCULATE STRESSES AND CONSTITUTIVE LAW
C
      CALL EPC2(A(NM),A(NN1),A(NN2),A(NN3),A(NN4),A(NN5),A(NN6),A(NN7),
     1          A(NN8),A(NN9),A(NN10),A(NN11),A(KK),A(LL),A(N6A + ITWO),
     2          A(N6B + ITWO))
C
  200 CONTINUE
C
      RETURN
      END
C *CDC* *DECK IEPC2
C *UNI* )FOR,IS  N.IEPC2, R.IEPC2
C
      SUBROUTINE IEPC2(WA,IWA,IIWA,IDW,TEMPV1,PROP)
C
C
C
C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR
C     THE THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
C     (MODELS = 10 AND 11)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /EM2D/ S(300),XM(24),B(4,16),RE(24),EDIS(24),EDISI(24),
     1              XX(24),NOD(8),NODM(8),NOD5M(4)
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /DPR/ ITWO
      COMMON /TODIM/ BET,THIC,DE,IEL,NND5
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1                TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2                SUBDD,RNGL,RNGU,DTT,TOL7,
     3                KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
      DIMENSION WA(33,1),IWA(1),IIWA(IDW,1),TEMPV1(1),H(8),
     1          XDM1(2,8),XDM2(2,2),XDM3(2,1),PROP(16,1),PROP1(5)
C
      EQUIVALENCE (NPAR(10),NINT)
C
      NPT=NINT*NINT
      IINTP=1
      NPTS=IDINT(PROP(9,7))
      TOLMT=1.0D-2
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C
C        1. SET ALL FLOATING-POINT VARIABLES IN THE WORKING ARRAY
C           TO ZERO
C
   15 DO 20 J=1,NPT
      DO 20 I=1,31
   20 WA(I,J)=0.0
C
C        2. STORE GLOBAL NODAL POINT NUMBERS
C
      II=0
      DO 25 K=1,8
      IF(NODM(K).EQ.0) GO TO 25
      II=II+1
      IWA(II)=NODM(K)
   25 CONTINUE
C
C        3. INTERPOLATE INITIAL TEMPERATURE DISTRIBUTION
C           STORE INITIAL INTEGRATION POINT TEMPERATURES
C
      DO 30 LX=1,NINT
      E1=XG(LX,NINT)
      DO 30 LY=1,NINT
      E2=XG(LY,NINT)
      IPT=(LX-1)*NINT+LY
      CALL FUNCT2(E1,E2,H,XDM1,NOD5M,XDM2,XDUM,XDM3,IDUM,IINTP)
      TEMP1=0.0
      DO 35 K=1,IEL
      KK=IWA(K)
   35 TEMP1=TEMP1+H(K)*TEMPV1(KK)
      WA(31,IPT)=TEMP1
C
C        4. INITIALIZE AND STORE YIELD STRESS
C
      CALL MTITP2(PROP,TEMP1,PROP1)
      YS1=PROP1(3)
   30 WA(17,IPT)=YS1
C
C        5. INITIALIZE INTEGER VARIABLES IN THE WORKING ARRAY
C           TO ONE
C
      KJ=31*ITWO + 1
      KJJ=32*ITWO + 1
      DO 40 I=1,NPT
      IIWA(KJ,I)=1
   40 IIWA(KJJ,I)=1
C
      RETURN
C
      END
C *CDC* *DECK EPC2
C *UNI* )FOR,IS  N.EPC2, R.EPC2
C
      SUBROUTINE EPC2(PROP,SIG,EPS,EPSP,EPSC,YLD,EPSTR,ALFA,ORIG,TMPOLD,
     1                IPEL,NORG,NDS,NOD5M,TEMPV1,TEMPV2)
C
C
C
C     THIS SUBROUTINE CALCULATES THE STRESSES, PLASTIC STRAINS,
C     CREEP STRAINS, AND THE CONSTITUTIVE LAW FOR THE
C     THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
C     (MODELS = 10 AND 11)
C
C
C
C     NALG = 1  ALGORITHM USES ISUBM SUBDIVISIONS OF EQUAL SIZE
C
C          = 2  ALGORITHM USES VARIABLE SIZE SUBDIVISIONS UP TO A
C               MAXIMUM OF ISUBM
C
C
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        SIG = STRESSES AT TIME OF LAST UPDATE
C        EPS = TOTAL STRAINS AT TIME OF LAST UPDATE
C        EPSP = PLASTIC STRAINS AT TIME OF LAST UPDATE
C        EPSC = CREEP STRAINS AT TIME OF LAST UPDATE
C        YLD = YIELD STRESS AT TIME OF LAST UPDATE
C        EPSTR = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT TIME OF LAST
C                UPDATE
C        ORIG = ORIGINS FOR O.R.N.L. CYCLIC CREEP AT TIME OF LAST UPDATE
C        ALFA = YIELD SURFACE TRANSLATION COMPONENTS AT TIME OF LAST
C               UPDATE
C        IPEL = ELASTIC-PLASTIC INDICATOR AT TIME OF LAST UPDATE
C        NORG = CYCLIC CREEP ORIGIN INDICATOR AT TIME OF LAST UPDATE
C        TREF = REFERENCE TEMPERATURE
C        KCRP = CREEP LAW NUMBER
C        CRPCON = CREEP LAW COEFFICIENTS
C        XINTP = INTEGRATION PARAMETER
C        ISUBM = MAXIMUM NUMBER OF SUBDIVISIONS
C        NITE = MAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION
C        NALG = ALGORITHM INDICATOR
C        TOLIL,TOL1 = CONVERGENCE TOLERANCES
C        TOL2,TOL5 = ZERO TOLERANCES
C        TOL3,TOL4 = ROUNDOFF TOLERANCES
C        TOL6,TOL7 = YIELD SURFACE TOLERANCES
C        TOLPC = INELASTIC STRAIN TOLERANCE
C        TOLMT = MATERIAL PROPERTY EXTREME TEMPERATURE TOLERANCE
C        DTT = CURRENT TIME STEP
C        DTOD = OLD TIME STEP WHEN USING RESTART
C        DELT = TIME STEP SUBDIVISION
C        STRAIN = TOTAL STRAINS
C        STRESS = STRESSES
C        DELEPS = INCREMENT IN TOTAL STRAINS
C        EPS1 = TOTAL STRAINS AT START OF SUBDIVISION
C        EPS2 = TOTAL STRAINS AT END OF SUBDIVISION
C        DEPS = CHANGE IN TOTAL STRAINS FOR THE SUBDIVISION
C        STRSS1,STRSS2 = STRESSES AT START AND END OF SUBDIVISION
C        STRSSM = WEIGHTED STRESSES
C        DELSIG = CHANGE IN STRESSES FOR THE SUBDIVISION
C        EPST1,EPST2 = THERMAL STRAINS AT START AND END OF SUBDIVISION
C        THSTR1 = THERMAL STRAIN RATE AT START OF SUBDIVISION
C        DPST = CHANGE IN THERMAL STRAINS FOR THE SUBDIVISION
C        EPSC1,EPSC2 = CREEP STRAINS AT START AND END OF SUBDIVISION
C        EPSCM = WEIGHTED CREEP STRAINS
C        DPSC = CHANGE IN CREEP STRAINS FOR THE SUBDIVISION
C        EPSP1,EPSP2 = PLASTIC STRAINS AT START AND END OF SUBDIVISION
C        DPSP = CHANGE IN PLASTIC STRAINS FOR THE SUBDIVISION
C        EPSTR1,EPSTR2 = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT START
C                        AND END OF SUBDIVISION
C        EPSTRM = WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C        TEMP1,TEMP2 = TEMPERATURES AT START AND END OF CURRENT
C                      SOLUTION STEP
C        TMP1,TMP2 = TEMPERATURES AT START AND END OF SUBDIVISION
C        TMPM = WEIGHTED TEMPERATURE
C        ALFA1,ALFA2 = YIELD SURFACE TRANSLATION COMPONENTS AT START
C                      AND END OF SUBDIVISION
C        ALFAM = WEIGHTED YIELD SURFACE TRANSLATION COMPONENTS
C        C = CONSTITUTIVE MATRIX  (ELASTIC OR ELASTIC-PLASTIC)
C        PROP1,PROP2 = MATERIAL PROPERTIES AT START AND END OF
C                      SUBDIVISION
C        PROPM = WEIGHTED MATERIAL PROPERTIES
C        YLD1,YLD2 = YIELD STRESS AT START AND END OF SUBDIVISION
C        YLDM = WEIGHTED YIELD STRESS
C        XLAMDA = LOADING/UNLOADING/NEUTRAL LOADING INDICATOR
C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /TODIM/ BET,THIC,DE,IEL,NND5
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),Z1,Z2,Z3
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
C
      DIMENSION PROP(16,1),SIG(1),EPS(1),EPSC(1),ALFA(1),ORIG(4,1),
     1          ORIGD(4,2),NDS(1),NOD5M(1),TEMPV1(1),TEMPV2(1),
     2          STATE(2),H(8),XDM1(2,8),XDM2(2,2),XDM3(2,1),
     3          DELSIG(4),DELEPS(4),DEPS(4),EPSP1(4),EPSP2(4),
     4          STRSS1(4),STRSS2(4),STRSSM(4),EPSC1(4),EPSC2(4),
     5          EPSCM(4),DPSC(4),ALFA1(4),ALFA2(4),ALFAM(4),
     6          EPS1(4),EPS2(4),PROP1(5),DEPST(4),PROP2(5),PROPM(5)
      DIMENSION STRSSD(4),DPSP(4),EPST2(4),EPSP(1),CEP(4,4),EPST1(4),
     1          DSTSS(4)
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(15),MODEL),(NPAR(3),INDNL)
      EQUIVALENCE (STRESS(1),STRSS2(1))
C
      DATA STATE /2H E,2H*P/
C
C
C
C        1. INITIALIZE SOLUTION PARAMETERS
C
      INDEX=1
      ISUB=1
      ISUBM=IDINT(PROP(13,7))
C
      IF(IPT.GT.1) GO TO 5
C
C     SET TIME STEP SIZE **
C
      DTT=DT
      IF(MODEX.EQ.2.AND.KSTEP.EQ.1.AND.ICOUNT.NE.3.AND.
     1   KPRI.NE.0) DTT=DTOD
C
      SUBDD=5.0
      DTMN=DTT/PROP(13,7)
      IINTP=1
C
      DO 2 J=1,8
    2 CRPCON(J)=PROP(J,7)
C
      NPTS=IDINT(PROP(9,7))
      TREF=PROP(10,7)
      KCRP=IDINT(PROP(11,7))
      XINTP=PROP(12,7)
      NITE=IDINT(PROP(14,7))
      NALG=IDINT(PROP(15,7))
      TOLIL=PROP(16,7)
      TOLPC=PROP(1,8)
C
      XCON1=2.0/3.0
      XCON2=1.0/3.0
C
      ITCHK=1
      IF(NITE.LT.6) ITCHK=0
C
C     SET INTEGRATION PARAMETERS **
C
      XPARM1=1.0 - XINTP
      XPARM2=XINTP
C
C     SET NUMBER OF STRESS AND STRAIN COMPONENTS **
C
      IST=4
      IF(ITYP2D.GE.2) IST=3
      ISR=3
      IF(ITYP2D.EQ.0) ISR=4
C
C     SET TOLERANCES **
C
      TOL1=TOLIL*TOLIL
      TOL4=5.0D-6
      TOL5=1.0D-20
      TOL2=TOL5*TOL5
      TOL3=2.0*TOL4
      TOL6=0.1
      TOL7=2.0
      TOLMT=1.0D-2
      TCHK=DTT*(1.0 - TOL4)
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C        2. INITIALIZE SOLUTION VARIABLES
C
    5 DELEPS(4)=0.0
      DEPS(4)=0.0
      EPS2(4)=0.0
      DELSIG(4)=0.0
      STRSSM(4)=0.0
      STRSSD(4)=0.0
C
      DO 10 I=1,4
      EPS1(I)=EPS(I)
      EPSP1(I)=EPSP(I)
      EPSP2(I)=EPSP(I)
      ALFA1(I)=ALFA(I)
      ALFA2(I)=ALFA(I)
      EPSC1(I)=EPSC(I)
      EPSC2(I)=EPSC(I)
      DPSC(I)=0.0
      EPST1(I)=0.0
      EPST2(I)=0.0
      DEPST(I)=0.0
      STRSS2(I)=SIG(I)
   10 STRSS1(I)=SIG(I)
C
      YLD1=YLD
      EPSTR1=EPSTR
      EPSTR2=EPSTR
      ECSTR1=0.0
      CRSRM=0.0
      TMP1=TMPOLD
      IPELD=IPEL
      NORGD=NORG
      TAU=0.0
      ESTM=0.0
C
      DO 20 I=1,4
      DO 20 J=1,2
   20 ORIGD(I,J)=ORIG(I,J)
C
C        3. CALCULATE TOTAL STRAIN INCREMENT
C
      DO 25 J=1,ISR
   25 DELEPS(J)=STRAIN(J) - EPS(J)
C
C        4. CALCULATE TEMPERATURE INCREMENT
C
C     CALCULATE INTEGRATION POINT TEMPERATURES **
C
      CALL FUNCT2(Z1,Z2,H,XDM1,NOD5M,XDM2,XDUM,XDM3,NEL,IINTP)
      TEMP1=0.0
      TEMP2=0.0
C
      DO 30 K=1,IEL
      KK=NDS(K)
      TEMP2=TEMP2 + H(K)*TEMPV2(KK)
   30 TEMP1=TEMP1 + H(K)*TEMPV1(KK)
C
      CTEMP=TEMP2
C
C     CHECK FOR START OF A SOLUTION STEP *
C
      IF(ICOUNT.NE.3.AND.KPRI.NE.0) CTEMP=TEMP1
C
      DELTMP=CTEMP - TMPOLD
C
C        5. CALCULATE MATERIAL PROPERTIES AT TIME OF LAST UPDATE
C
      CALL EMAT2(TMPOLD,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
C
      YM1=PROP1(1)
      ET1=PROP1(4)
      YS1=PROP1(3)
C
      EET1=YM1*ET1/(YM1 - ET1)
C
C        6. CALCULATE SIZE OF FIRST SUBDIVISION
C           (STRESS LOOP NO. 1)
C
   40 DELT=DTMN
      IF(KCRP.EQ.0.AND.NALG.EQ.2) DELT=DTT
C
C        7. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
C
   60 XFAC=(TAU + DELT)/DTT
      DO 65 J=1,ISR
      EPS2(J)=EPS(J) + XFAC*DELEPS(J)
   65 DEPS(J)=EPS2(J) - EPS1(J)
C
C        8. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C
      TMP2=TMPOLD + XFAC*DELTMP
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
      CALL EMAT2(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
C        9. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
C
      ALPHA2=PROP2(5)
C
      EPST2(1)=ALPHA2*(TMP2 - TREF)
      EPST2(2)=EPST2(1)
      EPST2(4)=EPST2(1)
C
C        10. CALCULATE WEIGHTED STRESS
C
      IF(KCRP.EQ.0) GO TO 95
C
   70 DO 75 J=1,IST
   75 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
C
C        11. PRELIMINARY CREEP CALCULATIONS
C
      DO 80 J=1,4
   80 DPSC(J)=0.0
      CRSRM=0.0
C
      CALL EFST(ESTM,SXM,SYM,SXYM,SZM,STRSSM)
      IF(ESTM.LE.TOL5.AND.INDEX.GT.1) GO TO 95
C
      DO 90 J=1,4
   90 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
C
      CALL CREEP2(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
     1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SXYM,SZM,FF,RR,GG,INDEX,
     2            ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        12. CALCULATE THE STRESSES AND CREEP STRAINS AT END OF
C             SUBDIVISION, ASSUMING THERMO-ELASTIC AND CREEP BEHAVIOR
C
   95 CALL SIGMA2(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SXYM,SZM,DELT,B2,C2,D2)
C
C        13. CHECK FOR CONVERGENCE OF ITERATION
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ. 0),
C     WHEN KCRP .EQ. 0, OR WHEN XPARM2 .EQ. 0 **
C
  100 IF(KCRP.EQ.0) GO TO 215
      IF(XPARM2.EQ.0.0) GO TO 205
      IF(ITCHK.EQ.1) GO TO 120
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 70
      GO TO 205
C
C     CALCULATE THE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
C     STRESS VECTOR **
C
  120 IF(INDEX - 4) 122,135,125
C
  122 INDEX=INDEX + 1
      GO TO 70
C
  125 DNORM2=0.0
      DO 130 J=1,IST
  130 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
C
C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
C
  135 SNORM=0.0
      DO 140 J=1,IST
  140 SNORM=SNORM + STRSS2(J)*STRSS2(J)
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 155
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      DO 150 J=1,IST
  150 STRSSD(J)=STRSS2(J)
      GO TO 70
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  155 IF(DNORM2.LE.DNORM1) GO TO 185
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 205
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 170
C
      WRITE(6,3004)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
C
  170 INDEX=1
C
      DO 180 I=1,4
      STRSS2(I)=STRSS1(I)
  180 EPSC2(I)=EPSC1(I)
C
      GO TO 60
C
C     FINAL CHECK FOR CONVERGENCE *
C
  185 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 205
C
C     NO CONVERGENCE
C
  190 INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 195
C
      WRITE(6,3001)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  195 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
C
      DO 200 J=1,IST
  200 STRSSD(J)=STRSS2(J)
      GO TO 70
C
C        14. CHECK SIZE OF CREEP STRAIN INCREMENT
C
C     CHECK IS BYPASSED WHEN THE MODIFIED EFFECTIVE CREEP STRAIN AT
C     THE START OF THE SUBDIVISION AND/OR THE EFFECTIVE CREEP STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0, OR WHEN KCRP .EQ. 0 **
C
  205 DECSTR=CRSRM*DELT
      IF(DECSTR.LE.TOL5 .OR. ECSTR1.LE.TOL5) GO TO 215
C
      CHECK=DECSTR/(ECSTR1*TOLPC)
      IF(CHECK.LE.1.1) GO TO 215
C
C     CREEP STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 208
C
      WRITE(6,3006)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
C
  208 INDEX=1
C
      DO 210 I=1,4
      EPSC2(I)=EPSC1(I)
  210 STRSS2(I)=STRSS1(I)
C
      GO TO 60
C
C        15. CHECK FOR YIELDING
C
C     DETERMINE LOCATION OF THE STRESS-TEMPERATURE STATE AT END OF
C     SUBDIVISION WITH RESPECT TO THE YIELD SURFACE (ASSUMING NO
C     PLASTICITY) **
C
  215 CALL EFST(EST2,SX2,SY2,SXY2,SZ2,STRSS2)
C
      DO 218 I=1,IST
  218 DELSIG(I)=STRSS2(I) - STRSS1(I)
C
      CALL EFST(EST,DX,DY,DXY,DZ,DELSIG)
C
C     KINEMATIC HARDENING **
C
      IF(MODEL.EQ.10) GO TO 220
C
      SX2=SX2 - ALFA1(1)
      SY2=SY2 - ALFA1(2)
      SXY2=SXY2 - ALFA1(3)
      SZ2=SZ2 - ALFA1(4)
C
C     CALCULATE YIELD STRESS AT END OF SUBDIVISION *
C
  220 YM2=PROP2(1)
      ET2=PROP2(4)
      YS2=PROP2(3)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
      DYLD=YS2 - YS1
      IF(MODEL.EQ.10) DYLD=DYLD + (EET2 - EET1)*EPSTR1
      YLD2=YLD1 + DYLD
C
  225 RA=DX*DX + DY*DY + DZ*DZ + 2.0*DXY*DXY
      FTA=SX2*SX2 + SY2*SY2 + SZ2*SZ2 + 2.0*SXY2*SXY2
C
C     CHECK FOR NO CHANGE IN DEVIATORIC STRESS-TEMPERATURE STATE *
C
      IF(RA.EQ.0.0.AND.TMP1.EQ.TMP2) GO TO 228
C
      FTB=XCON1*YLD2*YLD2
      IF(FTA.GT.FTB) GO TO 250
C
C        16. STRESS STATE IS WITHIN THE YIELD SURFACE---
C            THERMO-ELASTIC/CREEP BEHAVIOR
C
      IPELD=1
  228 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 230
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 248
      GO TO 235
C
C    NALG .EQ. 2 *
C
  230 IF(TAU.GE.TCHK.OR.KCRP.EQ.0) GO TO 248
      IF(DECSTR.LE.TOL5) GO TO 232
C
      DELT=DELT*TOLPC*(1.0 + (ECSTR1/DECSTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 233
C
  232 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  233 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 235
C
      WRITE(6,3007)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  235 ISUB=ISUB + 1
      INDEX=1
      YS1=YS2
      EET1=EET2
      YLD1=YLD2
      TMP1=TMP2
C
      DO 238 J=1,ISR
  238 EPS1(J)=EPS2(J)
C
      DO 240 J=1,4
      STRSS1(J)=STRSS2(J)
  240 EPSC1(J)=EPSC2(J)
C
      GO TO 60
C
C     AT END OF TIME STEP, CALCULATE THICKNESS NORMAL STRAIN FOR
C     CASE OF PLANE STRESS **
C
  248 IF(ITYP2D.GE.2) EPS2(4)=EPSP1(4) + EPSC2(4) + EPST2(4) + F2*
     1                        (STRSS2(1) + STRSS2(2))
C
C     AT END OF TIME STEP, CALCULATE YIELD STRESS USING DEFINITION
C     BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE PLASTIC STRAIN **
C
      YLDC=YS2
      IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
C
      GO TO 440
C
C        17. STRESS-TEMPERATURE STATE IS OUTSIDE THE YIELD
C            SURFACE---THERMO-ELASTIC-PLASTIC/CREEP BEHAVIOR
C
C            THERMO-ELASTIC-PLASTIC/CREEP STRESS CALCULATIONS
C            FOLLOW
C
C     CALCULATE THE FRACTION OF THE STRAIN SUBDIVISION OVER WHICH
C     THERE IS NO PLASTIC STRAINING **
C
  250 CALL EFST(EST1,SX1,SY1,SXY1,SZ1,STRSS1)
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.10) GO TO 255
C
      SX1=SX1 - ALFA1(1)
      SY1=SY1 - ALFA1(2)
      SXY1=SXY1 - ALFA1(3)
      SZ1=SZ1 - ALFA1(4)
C
  255 RB=SX1*DX + SY1*DY + SZ1*DZ + 2.0*SXY1*DXY
      RD=SX1*SX1 + SY1*SY1 + SZ1*SZ1 + 2.0*SXY1*SXY1
      RE=RB - (XCON1*YLD1*DYLD)
      RF=RA - (XCON1*DYLD*DYLD)
      RG=RD - (XCON1*YLD1*YLD1)
C
      IF(IPELD.EQ.2.OR.RG.GE.0.0) GO TO 270
C
C     STRESS-TEMPERATURE STATE IS WITHIN THE YIELD SURFACE AT
C     START OF SUBDIVISION *
C
  260 IF(DABS(RF).GT.TOL5) GO TO 265
      RATIO=-RG/(2.0*RE)
      GO TO 275
C
  265 RATIO=(-RE + DSQRT(RE*RE - RF*RG))/RF
      GO TO 275
C
C     STRESS-TEMPERATURE STATE IS ON THE YIELD SURFACE AT START
C     OF SUBDIVISION *
C
  270 RATIO=0.0
      IF(RF.GT.TOL5.AND.RE.LT.0.0) RATIO=-2.0*RE/RF
C
C     CHECK CALCULATED VALUE OF RATIO **
C
  275 IF(RATIO.GE.(-TOL6) .AND. RATIO.LE.(1.0 + TOL6)) GO TO 280
C
      WRITE(6,3012)
      WRITE(6,3013) NEL,IPT,ISUB,TAU,IPELD,RA,RB,RD,RE,RF,RG,RATIO
      STOP
C
  280 IF(RATIO.GT.1.0) RATIO=1.0
      IF(RATIO.LT.0.0) RATIO=0.0
      IPELD=2
C
C        18. UPDATE ALL VARIABLES TO START OF YIELDING
C
      TAU=TAU + RATIO*DELT
      TMP1=TMPOLD + DELTMP*TAU/DTT
      YLD1=YLD1 + RATIO*DYLD
      IF(RATIO.GT.TOL5) ISUB=ISUB + 1
      IF(ISUB.GT.ISUBM) ISUBM=ISUBM + 1
C
C     CALCULATE STRESSES, TOTAL STRAINS, AND CREEP STRAINS AT
C     START OF YIELDING **
C
      DO 282 J=1,4
      EPSC1(J)=EPSC1(J) + RATIO*DPSC(J)
      EPSC2(J)=EPSC1(J)
      STRSS1(J)=STRSS1(J) + RATIO*DELSIG(J)
  282 STRSS2(J)=STRSS1(J)
C
      DO 285 J=1,ISR
  285 EPS1(J)=EPS1(J) + RATIO*DEPS(J)
C
C     CALCULATE MATERIAL PROPERTIES AT START OF YIELDING **
C
  288 CALL EMAT2(TMP1,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
C
C     CALCULATE THERMAL STRAINS AT START OF YIELDING **
C
      ALPHA1=PROP1(5)
      EPST1(1)=ALPHA1*(TMP1 - TREF)
C
C        19. CALCULATE SIZE OF FIRST SUBDIVISION AFTER YIELDING
C            (STRESS LOOP NO. 2)
C
  290 XNWDT=DTT - TAU
      DELT=XNWDT/DBLE(FLOAT(ISUBM - ISUB + 1))
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
C
C        20. CALCULATE TEMPERATURE AT END OF SUBDIVISION
C            AND WEIGHTED TEMPERATURE
C
  292 TMP2=TMPOLD + DELTMP*(TAU + DELT)/DTT
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
C        21. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C            CALCULATE WEIGHTED MATERIAL PROPERTIES
C
      CALL EMAT2(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
      DO 295 J=1,5
  295 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
      YMM=PROPM(1)
      ETM=PROPM(4)
C
      EETM=YMM*ETM/(YMM - ETM)
      CEM=XCON1*EETM
C
C        22. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
C            AND THERMAL STRAIN INCREMENT FOR THE SUBDIVISION
C
      ALPHA2=PROP2(5)
C
      EPST2(1)=ALPHA2*(TMP2 - TREF)
      EPST2(2)=EPST2(1)
      EPST2(4)=EPST2(1)
C
      DPST=EPST2(1) - EPST1(1)
C
C        23. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
C            AND TOTAL STRAIN CHANGE FOR THE SUBDIVISION
C
  300 XFAC=(TAU + DELT)/DTT
      DO 305 J=1,ISR
      EPS2(J)=EPS(J) + XFAC*DELEPS(J)
  305 DEPS(J)=EPS2(J) - EPS1(J)
C
C        24. CALCULATE WEIGHTED STRESS
C
  310 DO 315 J=1,IST
  315 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
C
      CALL EFST(ESTM,SXM,SYM,SXYM,SZM,STRSSM)
C
C        25. CALCULATE WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
      EPSTRM=XPARM1*EPSTR1 + XPARM2*EPSTR2
C
C        26. CALCULATE WEIGHTED YIELD SURFACE TRANSLATION
C
      IF(MODEL.EQ.10) GO TO 320
C
      DO 318 J=1,4
  318 ALFAM(J)=XPARM1*ALFA1(J) + XPARM2*ALFA2(J)
      GO TO 324
C
C        27. CALCULATE WEIGHTED YIELD STRESS
C
C     ISOTROPIC HARDENING **
C
  320 YLDM=ESTM
      GO TO 328
C
C     KINEMATIC HARDENING **
C
  324 DO 325 J=1,4
  325 DSTSS(J)=STRSSM(J) - ALFAM(J)
C
      CALL EFST(YLDM,SXT,SYT,SXYT,SZT,DSTSS)
C
C        28. PRELIMINARY CREEP CALCULATIONS
C
  328 IF(KCRP.EQ.0) GO TO 335
C
      DO 330 J=1,4
  330 DPSC(J)=0.0
      CRSRM=0.0
C
      DO 332 J=1,4
  332 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
C
      CALL CREEP2(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
     1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SXYM,SZM,FF,RR,GG,INDEX,
     2            ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        29. CALCULATE PLASTIC STRAINS AT END OF SUBDIVISION
C
  335 CALL EPMAT2(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
     1            PROP1,PROP2,PROPM,YLDM,1,A2,B2,C1,C2,DPSP,SXM,SYM,
     2            SXYM,SZM,INDEX,EETM)
C
  342 DO 344 J=1,4
  344 EPSP2(J)=EPSP1(J) + DPSP(J)
C
      IF(XLAMDA.LE.0.0) GO TO 345
C
C        30. CALCULATE ACCUMULATED EFFECTIVE PLASTIC STRAIN AT END
C            OF SUBDIVISION
C
      DEPSTR=DSQRT(XCON1*(DPSP(1)*DPSP(1) + DPSP(2)*DPSP(2) + DPSP(4)*
     1            DPSP(4)) + XCON2*(DPSP(3)*DPSP(3)))
      EPSTR2=EPSTR1 + DEPSTR
C
C        31. CALCULATE YIELD SURFACE TRANSLATION AT END
C            OF SUBDIVISION
C
      IF(MODEL.EQ.10) GO TO 345
C
      ALFA2(1)=ALFA1(1) + CEM*DPSP(1)
      ALFA2(2)=ALFA1(2) + CEM*DPSP(2)
      ALFA2(3)=ALFA1(3) + 0.5*CEM*DPSP(3)
      ALFA2(4)=ALFA1(4) + CEM*DPSP(4)
C
C        32. CALCULATE THE STRESSES AND CREEP STRAINS AT
C            END OF SUBDIVISION
C
  345 CALL SIGMA2(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SXYM,SZM,DELT,B2,C2,D2)
C
C        33. CHECK FOR CONVERGENCE OF ITERATION
C
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ.0)
C     OR WHEN XPARM2 .EQ. 0.0 **
C
  350 IF(XPARM2.EQ.0.0) GO TO 400
      IF(ITCHK.EQ.1) GO TO 358
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 310
      GO TO 400
C
C     CALCULATE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
C     STRESS VECTOR **
C
  358 IF(INDEX - 4) 360,366,362
C
  360 INDEX=INDEX + 1
      GO TO 310
C
  362 DNORM2=0.0
      DO 365 J=1,IST
  365 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
C
C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
C
  366 SNORM=0.0
      DO 368 J=1,IST
  368 SNORM=SNORM + STRSS2(J)*STRSS2(J)
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 375
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      DO 370 J=1,IST
  370 STRSSD(J)=STRSS2(J)
      GO TO 310
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  375 IF(DNORM2.LE.DNORM1) GO TO 390
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 400
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 380
C
  378 WRITE(6,3008)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
C
  380 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      DO 385 I=1,4
      STRSS2(I)=STRSS1(I)
      EPSP2(I)=EPSP1(I)
      ALFA2(I)=ALFA1(I)
  385 EPSC2(I)=EPSC1(I)
C
      GO TO 292
C
C     FINAL CHECK FOR CONVERGENCE *
C
  390 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 400
C
C     NO CONVERGENCE
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 395
C
      WRITE(6,3003)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  395 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
C
      DO 398 J=1,IST
  398 STRSSD(J)=STRSS2(J)
      GO TO 310
C
C        34. CHECK SIZE OF INELASTIC STRAIN INCREMENT
C
C     CHECK IS BYPASSED WHEN THE EFFECTIVE INELASTIC STRAIN AT THE
C     START OF THE SUBDIVISION AND/OR THE EFFECTIVE INELASTIC STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0 **
C
  400 DECSTR=CRSRM*DELT
      DESTR=DECSTR + DEPSTR
      DENOM=ECSTR1 + EPSTR1
      IF(DESTR.LE.TOL5.OR.DENOM.LE.TOL5) GO TO 410
C
      CHECK=DESTR/(DENOM*TOLPC)
      IF(CHECK.LE.1.1) GO TO 410
C
C     INELASTIC STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 405
C
      WRITE(6,3009)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
C
  405 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      DO 408 I=1,4
      STRSS2(I)=STRSS1(I)
      EPSP2(I)=EPSP1(I)
      ALFA2(I)=ALFA1(I)
  408 EPSC2(I)=EPSC1(I)
C
      GO TO 292
C
C        35. CALCULATE YIELD STRESS AT END OF SUBDIVISION
C
  410 YM2=PROP2(1)
      ET2=PROP2(4)
      YS2=PROP2(3)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
C     USING DEFINITION BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE
C     PLASTIC STRAIN **
C
C     KINEMATIC HARDENING *
C
      YLDC=YS2
C
C     ISOTROPIC HARDENING *
C
      IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
C
C     USING STRESS STATE **
C
C     ISOTROPIC HARDENING *
C
      IF(MODEL.EQ.11) GO TO 412
      CALL EFST(YLD2,SX2,SY2,SXY2,SZ2,STRSS2)
      GO TO 414
C
C     KINEMATIC HARDENING *
C
  412 DO 413 J=1,4
  413 DSTSS(J)=STRSS2(J) - ALFA2(J)
C
      CALL EFST(YLD2,SXT,SYT,SXYT,SZT,DSTSS)
C
C        36. CORRECT STRESS STATE TO YIELD SURFACE
C
C     CHECK YIELD SURFACE ERROR **
C
  414 CHECK=DABS(YLD2 - YLDC)/DMIN1(YLD2,YLDC)
      IF(CHECK.LE.TOL7) GO TO 415
C
      WRITE(6,3014)
      WRITE(6,3015) NEL,IPT,ISUB,TAU,YLD2,YLDC
      STOP
C
C     *** THIS VERSION OF ADINA DOES NOT HAVE A CORRECTION FOR
C         ISOTHERMAL PERFECT PLASTICITY OR ISOTHERMAL KINEMATIC
C         HARDENING ***
C
C
C        37. UPDATE VARIABLES FOR NEXT SUBDIVISION
C
  415 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 416
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 438
      GO TO 425
C
C     NALG .EQ. 2 *
C
  416 IF(TAU.GE.TCHK) GO TO 438
      IF(DESTR.LE.TOL5) GO TO 420
C
      DELT=DELT*TOLPC*(1.0 + (DENOM/DESTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 422
C
  420 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  422 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 425
C
      WRITE(6,3010)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  425 ISUB=ISUB + 1
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      TMP1=TMP2
      EPSTR1=EPSTR2
      EPST1(1)=EPST2(1)
C
      A1=A2
      B1=B2
      C1=C2
      D1=D2
      E1=E2
      F1=F2
C
      DO 428 I=1,ISR
  428 EPS1(I)=EPS2(I)
C
      DO 430 J=1,4
      STRSS1(J)=STRSS2(J)
      EPSC1(J)=EPSC2(J)
      ALFA1(J)=ALFA2(J)
  430 EPSP1(J)=EPSP2(J)
C
      DO 435 J=1,5
  435 PROP1(J)=PROP2(J)
C
      GO TO 292
C
C     AT END OF TIME STEP, CALCULATE THICKNESS NORMAL STRAIN
C     FOR THE CASE OF PLANE STRESS **
C
  438 IF(ITYP2D.GE.2) EPS2(4)=EPSP2(4) + EPSC2(4) + EPST2(4) +
     1                        F2*(STRSS2(1) + STRSS2(2))
C
C        38. PERMANENT UPDATING OF VARIABLES
C
  440 IF(IUPDT.NE.0) GO TO 455
C
      DO 445 J=1,4
      SIG(J)=STRSS2(J)
      ALFA(J)=ALFA2(J)
      EPSC(J)=EPSC2(J)
      EPSP(J)=EPSP2(J)
  445 EPS(J)=STRAIN(J)
C
      IF(ITYP2D.GE.2) EPS(4)=EPS2(4)
      YLD=YLD2
      EPSTR=EPSTR2
      TMPOLD=TMP2
      IPEL=IPELD
      NORG=NORGD
C
      DO 450 I=1,4
      DO 450 J=1,2
  450 ORIG(I,J)=ORIGD(I,J)
C
C        39. CALCULATE LATEST CONSTITUTIVE LAW
C
C     CHECK FOR EQUILIBRIUM ITERATION **
C
  455 IF(ICOUNT.EQ.3) RETURN
C
C     CHECK FOR PRINTING OF STRESSES **
C
      IF(KPRI.EQ.0) GO TO 600
C
C     UPDATE SOLUTION VARIABLES **
C
      DO 458 J=1,4
      EPSC1(J)=EPSC2(J)
      EPSP1(J)=EPSP2(J)
      EPST1(J)=EPST2(J)
      STRSS1(J)=STRSS2(J)
  458 ALFA1(J)=ALFA2(J)
C
      YLD1=YLD2
      EPSTR1=EPSTR2
C
C     CALCULATE MATERIAL PROPERTIES AT END OF NEXT TIME STEP **
C
      A1=A2
      B1=B2
      C1=C2
      D1=D2
      E1=E2
      F1=F2
C
      DO 460 I=1,5
  460 PROP1(I)=PROP2(I)
C
      CALL EMAT2(TEMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
C     CALCULATE THERMAL STRAINS AT END OF NEXT TIME STEP **
C
      ALPHA2=PROP2(5)
      EPST=ALPHA2*(TEMP2 - TREF)
      DPST=EPST - EPST1(1)
C
      DO 465 J=1,4
      EPST2(J)=EPST
  465 DEPST(J)=DPST
C
      EPST2(3)=0.0
      DEPST(3)=0.0
C
C     ESTIMATE CREEP STRAINS AT END OF NEXT TIME STEP **
C
      INDEX=1
      CALL EFST(EST1,SX1,SY1,SXY1,SZ1,STRSS1)
C
      IF(KCRP.EQ.0) GO TO 480
C
      DO 470 J=1,4
  470 DPSC(J)=0.0
C
      IF(EST1.LE.TOL5) GO TO 480
      TMPM=XPARM1*TEMP1 + XPARM2*TEMP2
C
      CALL CREEP2(DT,DPSC,TMPM,EPSC1,ORIGD,NORGD,STRSS1,GAMA,CRSR1,
     1            PTIME,EST1,SX1,SY1,SXY1,SZ1,FF,RR,GG,INDEX,ECSTR1)
C
      DO 475 I=1,4
  475 EPSC2(I)=EPSC1(I) + DPSC(I)
C
C     CHECK ELASTIC-PLASTIC INDICATOR **
C
  480 IF(IPELD.EQ.2) GO TO 490
C
C     THERMO-ELASTIC AND CREEP BEHAVIOR **
C
      DO 482 J=1,4
  482 STRESS(J)=0.0
C
      DO 485 I=1,IST
      DO 485 J=1,IST
  485 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J) -
     1          EPST2(J))
C
      RETURN
C
C     THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR **
C
C
C     CALCULATE WEIGHTED MATERIAL PROPERTIES *
C
  490 DO 494 J=1,5
  494 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
C     ESTIMATE PLASTIC STRAINS AT END OF NEXT TIME STEP *
C
  500 YMM=PROPM(1)
      ETM=PROPM(4)
      EETM=YMM*ETM/(YMM - ETM)
C
      CALL EPMAT2(STRSS1,ALFA1,EPSTR1,DELEPS,DPSC,DPST,CEP,XLAMDA,
     1            PROP1,PROP2,PROPM,YLD1,2,A2,B2,C1,C2,DPSP,SX1,SY1,
     2            SXY1,SZ1,INDEX,EETM)
C
      DO 505 J=1,4
      STRESS(J)=0.0
  505 EPSP2(J)=EPSP1(J) + DPSP(J)
C
      IF(IEQREF.EQ.1 .OR. XLAMDA.LT. 0.0) GO TO 520
C
C     ITERATION WITH ELASTIC-PLASTIC STIFFNESS MATRIX *
C
      DO 510 I=1,IST
      DO 510 J=1,IST
  510 STRESS(I)=STRESS(I) - CEP(I,J)*(DPSC(J) + DEPST(J)) + C(I,J)*
     1          (STRAIN(J) - EPSP1(J) - EPSC1(J) - EPST1(J) - DPSP(J))
C
      DO 515 I=1,IST
      DO 515 J=1,IST
  515 C(I,J)=CEP(I,J)
C
      RETURN
C
C     ITERATION WITH ELASTIC STIFFNESS MATRIX WHEN GLOBAL DIVERGENCE
C     PROCEDURE IS ACTIVATED OR UNLOADING IS DETECTED *
C
  520 DO 535 I=1,IST
      DO 535 J=1,IST
  535 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J)
     1          - EPST2(J))
C
      RETURN
C
C        40. PRINTING OF STRESSES
C
C     CALCULATE EFFECTIVE STRESS **
C
  600 FT=YLD2
      IF(IPELD.EQ.1) FT=DSQRT(1.5*FTA)
C
C     IN TOTAL LAGRANGIAN FORMULATION, CALCULATE CAUCHY STRESSES **
C
  605 IF(INDNL.EQ.2) CALL CAUCHY
C
  610 IF(IPRI.NE.0) RETURN
      IF (IPS.LT.0) GO TO 700
C
C     STRESS PRINTOUT ONLY **
C
      IF(IPT.GT.1) GO TO 620
C
C     PRINT HEADING *
C
      WRITE(6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE(6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES *
C
  620 WRITE(6,2200) IPT,STATE(IPELD),STRSS2(4),(STRSS2(J),J=1,3)
      WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
C
      RETURN
C
C     STRESS AND STRAIN PRINTOUT **
C
  700 IF(IPT.GT.1) GO TO 720
C
C     PRINT HEADING *
C
      WRITE(6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE(6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES AND STRAINS *
C
  720 WRITE(6,2200) IPT,STATE(IPELD),STRSS2(4),(STRSS2(J),J=1,3)
      IF(ITYP2D.GE.2) STRAIN(4)=EPS2(4)
      WRITE(6,2300) STRAIN(4),(STRAIN(J),J=1,3)
      WRITE(6,2400) EPSP2(4),(EPSP2(J),J=1,3)
      WRITE(6,2500) EPSC2(4),(EPSC2(J),J=1,3)
      WRITE(6,2600) EPST2(4),(EPST2(J),J=1,3)
      WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
C
      RETURN
C
 2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,
     1        13X,2HYY,13X,2HZZ,13X,2HYZ,/,1X,7HNUM/IPT,3X,5HSTATE,
     2        4X,10HCOMPONENTS)
 2005 FORMAT (/,1X,I3)
 2200 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,4(E14.6,1X),
     1        2(1X,E14.6))
 2300 FORMAT (20X,12HSTRAIN-TOTAL,3X,4(E14.6,1X))
 2400 FORMAT (25X,7HPLASTIC,3X,4(E14.6,1X))
 2500 FORMAT (27X,5HCREEP,3X,4(E14.6,1X))
 2600 FORMAT (25X,7HTHERMAL,3X,4(E14.6,1X))
 2700 FORMAT (20X,14HTEMPERATURE = ,E14.6,1X,
     1        29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,1X,
     2        25HNUMBER OF SUBDIVISIONS = ,I5,/,20X,
     3        12HEFF STRESS = ,E14.6,1X,
     4        13HYLD STRESS = ,E14.6,1X,
     5        41HYLD STRESS(TMP.,ACC. EFF. PLAS. STRN.) = ,E14.6,/)
 3001 FORMAT(//,68H    ERROR   STRESS LOOP NO. 1 FAILED TO CONVERGE   (S
     1UBROUTINE EPC2))
 3002 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       13HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       40HAPPROXIMATE REQUIRED SUBDIVISION SIZE = ,E14.6)
 3003 FORMAT(//,68H    ERROR   STRESS LOOP NO. 2 FAILED TO CONVERGE   (S
     1UBROUTINE EPC2))
 3004 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBROUTINE EPC2))
 3006 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBRO
     2UTINE EPC2))
 3007 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 1   (SUBROUTINE EPC2))
 3008 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBROUTINE EPC2))
 3009 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBRO
     2UTINE EPC2))
 3010 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 2   (SUBROUTINE EPC2))
 3011 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       24HLAST SUBDIVISION SIZE = ,E14.6)
 3012 FORMAT(//,70H    ERROR   INCORRECT VALUE CALCULATED FOR *RATIO*
     1(SUBROUTINE EPC2))
 3013 FORMAT(//,5X,10HELEMENT = ,I5,1X,20HINTEGRATION POINT = ,I5,1X,
     1       14HSUBDIVISION = ,I5,1X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,1X,
     3        7HIPEL = ,I2,/,5X,
     4        5HRA = ,E14.6,1X,5HRB = ,E14.6,1X,5HRD = ,E14.6,
     5        5HRE = ,E14.6,1X,5HRF = ,E14.6,1X,5HRG = ,E14.6,/,5X,
     6        8HRATIO = ,E14.6,//)
 3014 FORMAT(//,101H    ERROR   DIFFERENCE BETWEEN THE TWO MEASURES OF Y
     1IELD STRESS EXCEEDS TOLERANCE   (SUBROUTINE EPC2))
 3015 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,2X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,/,5X,
     3       35HYIELD STRESS (FROM STRESS STATE) = ,E14.6,2X,
     4       54HYIELD STRESS (FROM TEMPERATURE AND ACCUM. EFF. PLASTIC,
     5       10HSTRAIN) = ,E14.6,//)
C
      END
C *CDC* *DECK SIGMA2
C *UNI* )FOR,IS  N.SIGMA2, R.SIGMA2
C
      SUBROUTINE SIGMA2(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,
     1                  PTIME,STRNR,F,R,G,EST,SX,SY,SXY,SZ,DELT,XB2,XC2,
     2                  XD2)
C
C
C
C     THIS SUBROUTINE USES A NEWTON-RAPHSON METHOD TO CALCULATE
C     STRESSES AND CREEP STRAINS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
      DIMENSION STRSS2(1),EPS2(1),EPSP2(1),EPST2(1),EPSC1(1),EPSC2(1),
     1          DPSC(1),TSTRSS(4),RH(4),TC(4,4),TTC(4,4)
C
C
C
      XFAC1=-XD2
C
      DO 10 J=1,4
      TSTRSS(J)=STRSS2(J)
   10 RH(J)=0.0
C
      DO 20 I=1,4
      DO 20 J=1,4
   20 TC(I,J)=0.0
C
C        1. FORM FIRST PART OF R.H.S. VECTOR
C
      DO 25 I=1,IST
      DO 25 J=1,IST
   25 RH(I)=RH(I) + C(I,J)*(EPS2(J) - EPSP2(J) - EPSC1(J) - DPSC(J)
     1      - EPST2(J))
C
      IF(XPARM2.GT.0.0.AND.KCRP.GT.0.AND.EST.GT.TOL5) GO TO 35
C
      DO 30 I=1,4
      EPSC2(I)=EPSC1(I) + DPSC(I)
   30 STRSS2(I)=RH(I)
C
      RETURN
C
C        2. FORM THE PART OF THE ITERATION MATRIX USED TO CALCULATE
C           THE R.H.S. VECTOR AND THE CREEP STRAIN INCREMENT
C
   35 A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 40
C
C     CREEP LAW NO. 1 **
C
      GG=1.5*(A1 - A2)*GAMA/(A2*EST*EST)
      GO TO 50
C
C     CREEP LAW NO. 2 **
C
   40 C2=A4 - 1.0
      C1=1.5*A2*A4*(A3**(-A4))
      C3=1.5*A1
      C4=1.5*A6
C
      D1=DEXP(-R*PTIME)*F
      D2=EST**C2
C
      DTPSP=(D1*(C3 - PTIME*C1*D2) - C3*F - PTIME*C4*G)/STRNR
C
      GG=(1.5*D1*(C1*D2 - R*(PTIME*C1*D2 + R*DTPSP - C3)) + 1.5*C4*G -
     1   1.5*GAMA)/(EST*EST)
C
   50 COEF=2.0*XC2*XPARM2*DELT
C
      TC(1,1)=COEF*(GG*SX*SX + XCON1*GAMA)
      TC(1,2)=COEF*(GG*SX*SY - XCON2*GAMA)
      TC(1,3)=COEF*(2.0*GG*SX*SXY)
      TC(1,4)=COEF*(GG*SX*SZ - XCON2*GAMA)
C
      TC(2,1)=TC(1,2)
      TC(2,2)=COEF*(GG*SY*SY + XCON1*GAMA)
      TC(2,3)=COEF*(2.0*GG*SY*SXY)
      TC(2,4)=COEF*(GG*SY*SZ - XCON2*GAMA)
C
      TC(3,1)=TC(1,3)
      TC(3,2)=TC(2,3)
      TC(3,3)=COEF*(2.0*GG*SXY*SXY + GAMA)
      TC(3,4)=COEF*(2.0*GG*SXY*SZ)
C
      TC(4,1)=TC(1,4)
      TC(4,2)=TC(2,4)
      TC(4,3)=TC(3,4)
      TC(4,4)=COEF*(GG*SZ*SZ + XCON1*GAMA)
C
      DO 55 I=1,4
      DO 55 J=1,4
   55 TTC(I,J)=TC(I,J)/(2.0*XC2)
C
C        3. FORM ITERATION MATRIX AND SECOND PART OF R.H.S. VECTOR
C
   80 IF(IST.EQ.4) GO TO 90
C
C     FOR PLANE STRESS, MODIFY TC(I,J) **
C
      DO 85 I=1,2
      DO 85 J=1,3
   85 TC(I,J)=TC(I,J) - XFAC1*TC(4,J)
C
   90 DO 95 I=1,IST
      DO 95 J=1,IST
   95 RH(I)=RH(I) + TC(I,J)*STRSS2(J)
C
      DO 110 J=1,IST
  110 TC(J,J)=TC(J,J) + 1.0
C
C        4. CALCULATE STRESSES AT END OF SUBDIVISION
C
      CALL EQSOL2(TC,RH,1,IST)
C
      DO 130 J=1,4
  130 STRSS2(J)=RH(J)
C
C        5. CALCULATE CREEP STRAINS AT END OF SUBDIVISION
C
      DO 160 I=1,4
      DO 150 J=1,IST
  150 DPSC(I)=DPSC(I) + TTC(I,J)*(STRSS2(J) - TSTRSS(J))
  160 EPSC2(I)=EPSC1(I) + DPSC(I)
C
      RETURN
C
      END
C *CDC* *DECK EQSOL2
C *UNI* )FOR,IS  N.EQSOL2, R.EQSOL2
C
      SUBROUTINE EQSOL2(A,R,KEY,N)
C
C
C
C     THIS SUBROUTINE SOLVES A SYSTEM OF LINEAR ALGEBRAIC
C     EQUATIONS USING GAUSSIAN ELIMINATION WITH COMPLETE PIVOTING
C
C     THE ROW MULTIPLIERS ARE STORED IN THE LOWER TRIANGULAR PART OF
C     THE REDUCED COEFFICIENT MATRIX
C
C     THE SOLUTION VARIABLES ARE RETURNED IN THE R.H.S. VECTOR
C
C     THE FOLLOWING VARIABLES ARE USED
C        A = COEFFICIENT MATRIX
C        R = R.H.S. VECTOR
C        N = NUMBER OF EQUATIONS
C        KEY = CONTROL VARIABLE
C            = 1 COMPLETE SOLUTION
C            = 2 R.H.S. REDUCTION AND BACK-SUBSTITUTION
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(4,4),R(4),ICOL(4),TR(4),IROW(4)
C
C
C
      EPS=1.0D-50
      NN=N-1
      IF(KEY.EQ.2) GO TO 110
C
      DO 10 I=1,N
      IROW(I)=I
   10 ICOL(I)=I
C
      DO 100 J=1,NN
C
C        1. SEARCH FOR LARGEST PIVOT
C
      PIVI=0.0
      DO 20 I=J,N
      DO 20 K=J,N
      IF(DABS(A(I,K)).LE.DABS(PIVI)) GO TO 20
      IMAX=I
      KMAX=K
      PIVI=A(I,K)
   20 CONTINUE
C
      IF(DABS(PIVI).GT.EPS) GO TO 25
      WRITE(6,7000)
      WRITE(6,7010) J
      STOP
C
C        2. INTERCHANGE COLUMNS
C
   25 IF(KMAX.EQ.J) GO TO 40
C
      ISAVE=ICOL(KMAX)
      ICOL(KMAX)=ICOL(J)
      ICOL(J)=ISAVE
C
      DO 30 JJ=1,N
      SAVE=A(JJ,KMAX)
      A(JJ,KMAX)=A(JJ,J)
   30 A(JJ,J)=SAVE
C
C        3. INTERCHANGE ROWS
C
   40 IF(IMAX.EQ.J) GO TO 85
C
      ISAVE=IROW(IMAX)
      IROW(IMAX)=IROW(J)
      IROW(J)=ISAVE
C
      DO 50 K=1,N
      SAVE=A(J,K)
      A(J,K)=A(IMAX,K)
   50 A(IMAX,K)=SAVE
C
      SAVE=R(J)
      R(J)=R(IMAX)
      R(IMAX)=SAVE
C
C        4. REDUCE COEFFICIENT MATRIX AND STORE MULTIPLIERS
C
   85 I2=J + 1
      DO 90 K2=I2,N
      XMULT=A(K2,J)/PIVI
      A(K2,J)=XMULT
      DO 90 J2=I2,N
   90 A(K2,J2)=A(K2,J2) - XMULT*A(J,J2)
C
  100 CONTINUE
      GO TO 150
C
C        5. REDUCE R.H.S. VECTOR
C
C     FOR KEY = 2, REORDER R.H.S. VECTOR **
C
  110 DO 120 J=1,N
      K=IROW(J)
  120 TR(J)=R(K)
C
      DO 130 J=1,N
  130 R(J)=TR(J)
C
  150 DO 200 J=1,NN
      I2=J + 1
      DO 200 K2=I2,N
      XMULT=A(K2,J)
  200 R(K2)=R(K2) - XMULT*R(J)
C
C        6. BACK-SUBSTITUTION
C
      DO 320 I=1,N
      TSUM=0.0
      II=N + 1 - I
      IF(II.EQ.N) GO TO 315
      JJ=II + 1
C
      DO 310 K=JJ,N
  310 TSUM=TSUM + A(II,K)*R(K)
C
  315 R(II)=(R(II) - TSUM)/A(II,II)
  320 CONTINUE
C
C        7. REORDER VARIABLES TO ACCOUNT FOR PIVOTING
C
      DO 330 J=1,N
      K=ICOL(J)
  330 TR(K)=R(J)
C
      DO 340 J=1,N
  340 R(J)=TR(J)
C
      RETURN
C
 7000 FORMAT(///,64H   ERROR   UNABLE TO OBTAIN NON-ZERO PIVOT   (SUBROU
     1TINE EQSOL2))
 7010 FORMAT(/,10X,15HPIVOT NUMBER = ,I5)
C
      END
C *CDC* *DECK EFST
C *UNI* )FOR,IS  N.EFST, R.EFST
C
      SUBROUTINE EFST(EST,SX,SY,SS,SZ,STRESS)
C
C
C
C     THIS SUBROUTINE CALCULATES THE DEVIATORIC STRESS
C     COMPONENTS AND THE EFFECTIVE STRESS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1                TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2                SUBDD,RNGL,RNGU,DTT,TOL7,
     3                KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
      DIMENSION STRESS(4)
C
      SM=(STRESS(1) + STRESS(2) + STRESS(4))*XCON2
      SX=STRESS(1)-SM
      SY=STRESS(2)-SM
      SS=STRESS(3)
      SZ=STRESS(4)-SM
      EST=DSQRT(1.5*(SX*SX + SY*SY + 2.0*SS*SS + SZ*SZ))
C
      RETURN
C
      END
C *CDC* *DECK EPMAT2
C *UNI* )FOR,IS  N.EPMAT2, R.EPMAT2
C
      SUBROUTINE EPMAT2(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
     1                  PROP1,PROP2,PROPM,YLDM,KEY,A2,B2,C1,C2,DPSP,SXM,
     2                  SYM,SXYM,SZM,INDEX,EETM)
C
C
C     THIS SUBROUTINE CALCULATES PLASTIC STRAIN INCREMENTS AND THE
C     ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C
C
C
C     KEY = 1  CALCULATE PLASTIC STRAIN INCREMENTS
C              (STRESS CALCULATIONS)
C         = 2  CALCULATE PLASTIC STRAIN INCREMENTS AND THE
C              ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C              (FORMING STIFFNESS MATRIX)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
      COMMON /TPLAS2/ ECAM,ECBM,ECCM,EETD,COEF1,COEF2,PRM,CM,CD,
     1                YSD
C
      DIMENSION STRSSM(1),ALFAM(1),DEPS(1),DPSC(1),PROP1(1),PROP2(1),
     1          PROPM(1),CEP(4,4),DPSP(4)
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(15),MODEL)
C
C
C
C
C        1. INITIALIZE VARIABLES
C
      SXT=SXM
      SYT=SYM
      SXYT=SXYM
      SZT=SZM
C
      IF(INDEX.GT.1) GO TO 40
C
      YMM=PROPM(1)
      PRM=PROPM(2)
      ETM=PROPM(4)
C
      YMD=PROP2(1) - PROP1(1)
      PRD=PROP2(2) - PROP1(2)
      ETD=PROP2(4) - PROP1(4)
      YSD=PROP2(3) - PROP1(3)
C
      CD=C2 - C1
      CM=0.5*YMM/(1.0 + PRM)
      EETD=((YMM*YMM*ETD) - (ETM*ETM*YMD))/((YMM - ETM)*(YMM - ETM))
C
      IF(ITYP2D.LT.2) GO TO 40
C
      ECBM=1.0 - PRM*PRM
      ECAM=YMM/ECBM
      ECCM=1.0 + PRM*PRM
C
      COEF1=(ECBM*YMD + 2.0*YMM*PRM*PRD)/(YMM*ECBM*ECBM)
      COEF2=(YMM*PRD*ECCM + YMD*PRM*ECBM)/(YMM*ECBM*ECBM)
C
C        2. CALCULATE PLASTIC STRAIN INCREMENT
C
C
C     KINEMATIC HARDENING **
C
   40 IF(MODEL.EQ.10) GO TO 45
C
      SXM=SXM - ALFAM(1)
      SYM=SYM - ALFAM(2)
      SXYM=SXYM - ALFAM(3)
      SZM=SZM - ALFAM(4)
C
C     PLANE STRESS **
C
   45 IF(ITYP2D.LT.2) GO TO 50
C
      WP1=0.5*ECAM*((SXM + PRM*SYM)*(DEPS(1) - DPSC(1) - DPST) + (SYM +
     1    PRM*SXM)*(DEPS(2) - DPSC(2) - DPST)) + CM*SXYM*(DEPS(3) -
     2    DPSC(3))
C
      WP2=0.5*COEF1*(SXM*STRSSM(1) + SYM*STRSSM(2) - PRM*(SXM*
     1    STRSSM(2) + SYM*STRSSM(1)))
C
      WP2=WP2 + 0.5*COEF2*(SXM*STRSSM(2) + SYM*STRSSM(1) - PRM*(SXM*
     1    STRSSM(1) + SYM*STRSSM(2))) + (CD/CM)*SXYM*STRSSM(3)
C
      DENMP=(2.0*XCON2*XCON2*YLDM*YLDM*EETM) + 0.5*ECAM*(SXM*SXM +
     1       SYM*SYM + 2.0*PRM*SXM*SYM) + 2.0*CM*SXYM*SXYM
C
      GO TO 60
C
C     PLANE STRAIN/AXISYMMETRIC **
C
   50 WP1=CM*(SXM*(DEPS(1) - DPSC(1) - DPST) + SYM*(DEPS(2) - DPSC(2) -
     1    DPST) + SXYM*(DEPS(3) - DPSC(3)) + SZM*(DEPS(4) - DPSC(4) -
     2    DPST))
C
      WP2=(0.5*CD/CM)*(SXM*STRSSM(1) + SYM*STRSSM(2) + 2.0*SXYM*
     1     STRSSM(3) + SZM*STRSSM(4))
C
      DENMP=(XCON1*YLDM*YLDM)*(CM + EETM*XCON2)
C
   60 WP=WP1 + WP2
C
      IF(MODEL.EQ.11) GO TO 65
C
C     ISOTROPIC HARDENING *
C
      XLAMDA=(WP - (YLDM*XCON2)*(EPSTRM*EETD + YSD))/DENMP
      WPP=XLAMDA
      GO TO 70
C
C     KINEMATIC HARDENING *
C
   65 XLAMDA=(WP - (YLDM*YSD*XCON2))/DENMP
      WPP=XLAMDA
C
C     CHECK FOR UNLOADING OR NEUTRAL LOADING **
C
   70 IF(XLAMDA.GT.0.0) GO TO 75
      XLAMDA=0.0
      GO TO 80
C
   75 IF(KEY.EQ.2 .AND. IEQREF.NE.1) XLAMDA=XLAMDA -WP1/DENMP
C
   80 DPSP(1)=XLAMDA*SXM
      DPSP(2)=XLAMDA*SYM
      DPSP(3)=2.0*XLAMDA*SXYM
      DPSP(4)=XLAMDA*SZM
C
      XLAMDA=WPP
C
      IF(KEY.EQ.2 .AND. IEQREF.NE.1 .AND. XLAMDA.GE.0.0) GO TO 90
C
      SXM=SXT
      SYM=SYT
      SXYM=SXYT
      SZM=SXT
C
      RETURN
C
C        3. CALCULATE ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C
   90 YLD1=YLDM
C
      SX1=SXM
      SY1=SYM
      SXY1=SXYM
      SZ1=SZM
C
      YIELD=YLD1*YLD1/(3.0*C2)
      GAMA1=1.0/(YIELD*(1.0 + EETM/(3.0*CM)))
C
      GAMA=GAMA1*SX1
      CEP(1,1)=A2 - GAMA*SX1
      CEP(1,2)=B2 - GAMA*SY1
      CEP(1,3)=   - GAMA*SXY1
      CEP(1,4)=B2 - GAMA*SZ1
C
      GAMA=GAMA1*SY1
      CEP(2,1)=CEP(1,2)
      CEP(2,2)=A2 - GAMA*SY1
      CEP(2,3)=   - GAMA*SXY1
      CEP(2,4)=B2 - GAMA*SZ1
C
      GAMA=GAMA1*SXY1
      CEP(3,1)=CEP(1,3)
      CEP(3,2)=CEP(2,3)
      CEP(3,3)=C2 - GAMA*SXY1
      CEP(3,4)=   - GAMA*SZ1
C
      GAMA=GAMA1*SZ1
      CEP(4,1)=CEP(1,4)
      CEP(4,2)=CEP(2,4)
      CEP(4,3)=CEP(3,4)
      CEP(4,4)=A2 - GAMA*SZ1
C
      IF(ITYP2D.LT.2) RETURN
C
C     CONDENSE MATRIX FOR PLANE STRESS **
C
      DO 100 I=1,3
      FAC=CEP(I,4)/CEP(4,4)
      DO 100 J=I,3
      CEP(I,J)=CEP(I,J) - CEP(4,J)*FAC
  100 CEP(J,I)=CEP(I,J)
C
      RETURN
C
      END
C *CDC* *DECK EMAT2
C *UNI* )FOR,IS  N.EMAT2, R.EMAT2
C
      SUBROUTINE EMAT2(TMP,PROP,PROPI,XA1,XB1,C1,D1,E1,F1,KKK)
C
C
C
C     THIS SUBROUTINE CALCULATES THE ELASTIC AND INVERSE ELASTIC
C     PROPERTIES FOR A SPECIFIED TEMPERATURE AND FORMS THE ELASTIC
C     CONSTITUTIVE MATRIX
C
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
C
      DIMENSION PROP(16,1),PROPI(1)
C
      EQUIVALENCE (NPAR(5),ITYP2D)
C
C
C
C
C        1. INTERPOLATE MATERIAL PROPERTY TABLES
C
      CALL MTITP2(PROP,TMP,PROPI)
      YM=PROPI(1)
      PR=PROPI(2)
C
C        2. CALCULATE ELASTIC CONSTANTS
C
      A2=YM/(1.0 + PR)
      C1=A2*0.5
      A2=A2/(1.0 - 2.0*PR)
      B2=A2*PR
      A2=A2 - B2
      A1=A2
      B1=B2
      XA1=A1
      XB1=B1
      D1=PR/(PR - 1.0)
      E1=1.0/YM
      F1=-PR*E1
C
      IF(ITYP2D.LT.2) GO TO 30
C
C        PLANE STRESS **
C
   20 A1=YM/(1.0 - PR*PR)
      B1=PR*A1
C
C        3. FORM ELASTIC CONSTITUTIVE MATRIX
C
   30 IF(KKK.EQ.1) RETURN
C
      DO 40 I=1,4
      DO 40 J=1,4
   40 C(I,J)=0.0
C
      C(1,1)=A1
      C(1,2)=B1
      C(2,1)=B1
      C(2,2)=A1
      C(3,3)=C1
C
      IF(ITYP2D.GE.2) RETURN
C
      C(1,4)=B1
      C(2,4)=B1
      C(4,1)=B1
      C(4,2)=B1
      C(4,4)=A1
C
      RETURN
C
      END
C *CDC* *DECK MTITP2
C *UNI* )FOR,IS  N.MTITP2, R.MTITP2
C
      SUBROUTINE MTITP2(PROP,TMP,PROPI)
C
C
C
C     THIS SUBROUTINE LINEARLY INTERPOLATES THE MATERIAL PROPERTY
C     TABLES AND OBTAINS THE FOLLOWING PROPERTIES AT THE
C     SPECIFIED TEMPERATURE
C
C        YOUNGS MODULUS
C        POISSONS RATIO
C        VIRGIN MATERIAL YIELD STRESS
C        HARDENING MODULUS
C        MEAN COEFFICIENT OF THERMAL EXPANSION
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
C
      DIMENSION PROP(16,1),PROPI(1)
C
C
C
C
C        1. ENTER TEMPERATURE TABLE AND DETERMINE
C           INTERPOLATION FACTOR
C
    5 IF(TMP.GE.RNGL) GO TO 10
      WRITE(6,3001)
      STOP
C
   10 L=0
      DO 20 K=2,NPTS
      L=L + 1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(TMP.GT.DUM) GO TO 20
      GO TO 25
   20 CONTINUE
      WRITE(6,3001)
      STOP
C
   25 XRATIO=(TMP - PROP(L,1))/(PROP(L + 1,1) - PROP(L,1))
C
C     CORRECT XRATIO FOR THE CASE WHEN TMP LIES OUTSIDE TABLE
C     BUT WITHIN THE TOLERANCE RANGE **
C
      IF(XRATIO.GT.1.0) XRATIO=1.0
      IF(XRATIO.LT.0.0) XRATIO=0.0
C
C        2. INTERPOLATE MATERIAL PROPERTIES
C
C     PROPI(J) CONTAINS INTERPOLATED VALUES **
C
C        PROPI(1) = YOUNGS MODULUS
C        PROPI(2) = POISSONS RATIO
C        PROPI(3) = VIRGIN MATERIAL YIELD STRESS
C        PROPI(4) = HARDENING MODULUS
C        PROPI(5) = MEAN COEFFICIENT OF THERMAL EXPANSION
C
      DO 30 M=2,6
   30 PROPI(M - 1)=PROP(L,M) + XRATIO*(PROP(L + 1,M) - PROP(L,M))
C
      RETURN
C
 3001 FORMAT(//,92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PRO
     1PERTY TEMPERATURES  (SUBROUTINE MTITP2))
C
      END
C *CDC* *DECK CREEP2
C *UNI* )FOR,IS  N.CREEP2, R.CREEP2
C
      SUBROUTINE CREEP2(DDT,DEPSC,TEMPD,EPSC,ORIG,NORG,STRESS,GAMA,
     1                  STRNR,PTIME2,EST,SX,SY,SXY,SZ,F,R,G,INDEX,
     2                  ECSTR)
C
C
C
C     THIS SUBROUTINE CALCULATES THE CREEP STRAIN RATE USING TOTAL
C     CREEP STRAIN HARDENING AND THE ORNL AUXILIARY HARDENING RULES FOR
C     CYCLIC CREEP
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
      DIMENSION DEPSC(4),ORIG(4,1),EPSC(1),STRESS(1)
C
C
C
      IMAX=50
      ETOL1=5.0D-3
      ETOL4=5.0D-6
      ETOL5=1.0D-20
C
C        1. CALCULATE THE CURRENT VALUE OF EFFECTIVE CREEP STRAIN
C
   10 CALL CYCRP2(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
      IF(EST.LE.TOL5) RETURN
C
      IF(KCRP.EQ.2) GO TO 20
C
C        2. ANALYTICAL SOLUTION FOR CREEP LAW NO. 1
C
      CALL CRPLW2(EST,ECSTR,STRN,STRNR,DDT,TEMPD,F,R,G)
      GO TO 60
C
C        3. NUMERICAL SOLUTION FOR CREEP LAW NO. 2
C
C
C     USE NEWTON ITERATION TO SOLVE FOR CURRENT EFFECTIVE
C     CREEP STRAIN RATE **
C
C
C     MAKE INITIAL GUESS OF PSEUDO-TIME *
C
   20 PTIME1=DBLE(FLOAT(KSTEP))*DTT + TSTART
      PTIME2=PTIME1
C
      KOUNT=1
   25 CALL CRPLW2(EST,ECSTR,STRN,STRNR,PTIME2,TEMPD,F,R,G)
C
      IMOD=0
      FUNCT=STRN-ECSTR
      DELTA=FUNCT/STRNR
      IF(ECSTR.EQ.0.0) DELTA=PTIME2
C
C     MODIFY DELTA, IF NECESSARY, TO OBTAIN A VALUE
C     OF PSEUDO-TIME .GE. 0.0 **
C
      IF((PTIME2 - DELTA).GE.0.0) GO TO 30
      DELTA=0.5*PTIME2
      IMOD=1
C
   30 IF(KOUNT.GT.1) GO TO 40
      PTIME2=PTIME1 - DELTA
      DNORM1=DABS(DELTA)
      KOUNT=KOUNT + 1
      GO TO 25
C
C     APPLY CONVERGENCE CRITERIA FOR KOUNT .GT.1 **
C
   40 DNORM2=DABS(DELTA)
      IF(IMOD.EQ.1) GO TO 50
      IF(DNORM2.LE.DNORM1) GO TO 45
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND **
C
      XTOL=ETOL4*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM2.LE.XTOL.AND.DNORM1.LE.XTOL) GO TO 60
      GO TO 50
C
   45 XTOL=ETOL1*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM1.LE.XTOL) GO TO 60
C
C     NO CONVERGENCE *
C
   50 KOUNT=KOUNT + 1
      IF(KOUNT.LE.IMAX) GO TO 55
      WRITE(6,2000)
      STOP
C
   55 PTIME1=PTIME2
      PTIME2=PTIME2 - DELTA
      DNORM1=DNORM2
      GO TO 25
C
C        4. CALCULATE INITIAL ESTIMATE OF INCREMENTAL CREEP STRAINS
C
   60 GAMA=1.5*STRNR/EST
      C1=GAMA*DDT
C
  100 DEPSC(1)=C1*SX
      DEPSC(2)=C1*SY
      DEPSC(3)=C1*2.0*SXY
      DEPSC(4)=C1*SZ
C
      RETURN
C
 2000 FORMAT(//,69H    ERROR   NEWTON ITERATION FAILED TO CONVERGE   (SU
     1BROUTINE CREEP2))
C
      END
C *CDC* *DECK CYCRP2
C *UNI* )FOR,IS  N.CYCRP2, R.CYCRP2
C
      SUBROUTINE CYCRP2(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
C
C
C
C     THIS SUBROUTINE PERFORMS THE ORNL-TM-3602 AUXILIARY STRAIN
C     HARDENING CALCULATIONS FOR CYCLIC CREEP
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        ORIG(I,J)   =  ARRAY CONTAINING POSITIVE ORIGIN IN THE FIRST
C                       COLUMN AND NEGATIVE ORIGIN IN THE SECOND
C        EPSD        =  DISTANCE BETWEEN CURRENT ORIGINS
C        EPSC(I)     =  CURRENT CREEP STRAIN COMPONENTS
C        NORG        =  DENOTES CURRENT ORIGIN
C                    =  1 POSITIVE ORIGIN
C                    =  2 NEGATIVE ORIGIN
C        STRESS(I)   =  CURRENT STRESSES
C        ECSTR       =  EFFECTIVE STRAIN MEASURE OF THE DISTANCE BETWEEN
C                       THE CURRENT CREEP STRAIN STATE AND ORIGIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION STRESS(1),EPSC(1),ORIG(4,1)
C
C
C     STRESS REVERSAL CAN OCCUR ONLY AT THE START OF A
C     SUBDIVISION (INDEX = 1)
C
      IF(INDEX.GT.1) GO TO 50
C
C
C        1. CALCULATE CURRENT DISTANCE BETWEEN ORIGINS
C
      CALL EFCSTR(EPSD,ORIG,ORIG,2)
C
C        2. CHECK FOR STRESS REVERSAL
C
      DUM=0.0
      DO 15 I=1,4
   15 DUM=DUM+(EPSC(I)-ORIG(I,NORG))*STRESS(I)
      IF(DUM.GE.0.0) GO TO 50
C
C     STRESS REVERSAL IS INDICATED **
C
      CALL EFCSTR(ECSTR,EPSC,ORIG,NORG)
C
C     CHECK IF OPPOSITE ORIGIN COORDINATES MUST BE RESET TO
C     NEW VALUES **
C
      IF(ECSTR.GT.EPSD) GO TO 40
C
C     CHECK FOR FALSE STRESS REVERSAL *
C
      IF(NORG.EQ.2) GO TO 18
   17 NN=2
      GO TO 19
   18 NN=1
   19 DUM=0.0
C
      DO 20 I=1,4
   20 DUM=DUM+(EPSC(I)-ORIG(I,NN))*STRESS(I)
      IF(DUM.GE.0.0) GO TO 25
C
C     FALSE REVERSAL IS INDICATED
C
      CALL EFCSTR(TECSTR,EPSC,ORIG,NN)
      IF(ECSTR.GE.TECSTR) RETURN
C
C        3. RESET ORIGIN INDICATOR ONLY
C
   25 IF(NORG.EQ.2) GO TO 35
   30 NORG=2
      GO TO 50
   35 NORG=1
      GO TO 50
C
C        4. RESET ORIGIN INDICATOR AND COORDINATES
C
   40 IF(NORG.EQ.2) GO TO 42
   41 NORG=2
      GO TO 45
   42 NORG=1
C
   45 DO 48 I=1,4
   48 ORIG(I,NORG)=EPSC(I)
C
C        5. CALCULATE NEW VALUE OF EFFECTIVE CREEP STRAIN
C
   50 CALL EFCSTR(ECSTR,EPSC,ORIG,NORG)
C
      RETURN
C
      END
C *CDC* *DECK CRPLW2
C *UNI* )FOR,IS  N.CRPLW2, R.CRPLW2
C
      SUBROUTINE CRPLW2(STRESS,ECSTR,STRAIN,STRNR,TIME,TEMPD,F,R,G)
C
C
C
C     THIS SUBROUTINE CONTAINS THE UNIAXIAL CREEP LAWS FOR MATERIAL
C     MODELS 10 AND 11 (2-D)
C
C
C     THE FOLLOWING VARIABLES ARE USED FOR THE UNIAXIAL LAWS
C
C        STRESS = UNIAXIAL STRESS
C        STRAIN = UNIAXIAL CREEP STRAIN
C        STRNR = UNIAXIAL CREEP STRAIN RATE
C        TIME = TIME
C        TEMPD = TEMPERATURE
C        CRPCON = CONSTANTS FOR UNIAXIAL CREEP LAW
C        ECSTR = MODIFIED EFFECTIVE CREEP STRAIN (O.R.N.L. RULES)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
C
C
      A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 50
C
C        1. CREEP LAW NO. 1
C
      IF(A2.GE.1.0) GO TO 20
C
      RTTOL=20.
      EX1=1./(1.-A2)
      EX2=A1*EX1
      EX3=A2*EX1
      EX4=-RTTOL*EX3
C
C     CALCULATE MINIMUM ALLOWABLE EFFECTIVE CREEP STRAIN **
C
      ECMIN=(A0**EX1)*(STRESS**EX2)*(A2**EX3)*(10.0**EX4)
      IF(ECSTR.LE.ECMIN) GO TO 40
C
   20 EX5=1.0/A2
      EX6=A1*EX5
      EX7=(A2-1.)/A2
      IF(A2.EQ.1.0.AND.ECSTR.EQ.0.0) GO TO 25
      EX8=ECSTR**EX7
      GO TO 30
   25 EX8=1.0
C
   30 STRNR=(A0**EX5)*(STRESS**EX6)*A2*EX8
C
      RETURN
C
   40 STRAIN=A0*(STRESS**A1)*(TIME**A2)
      STRNR=STRAIN/TIME
C
      RETURN
C
C        2. CREEP LAW NO. 2
C
   50 F=A0*DEXP(A1*STRESS)
      R=A2*((STRESS/A3)**A4)
      G=A5*DEXP(A6*STRESS)
      STRAIN=F*(1.-DEXP(-R*TIME)) + (G*TIME)
      STRNR=F*R*DEXP(-R*TIME) + G
C
      RETURN
C
      END
C *CDC*  *DECK EFCSTR
C *UNI* )FOR,IS  N.EFCSTR, R.EFCSTR
C
      SUBROUTINE EFCSTR(ECSTR,EPSC,ORIG,NORG)
C
C
C
C     THIS SUBROUTINE CALCULATES THE EFFECTIVE CREEP STRAIN BASED ON THE
C     DISTANCE BETWEEN THE CURRENT CREEP STRAIN STATE AND THE
C     CURRENT ORIGIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM2/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     1               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
C
      DIMENSION DEPSC(4),EPSC(1),ORIG(4,1)
C
C
C
      DO 10 I=1,4
   10 DEPSC(I)=EPSC(I)-ORIG(I,NORG)
C
      ECSTR=DSQRT(XCON1*(DEPSC(1)*DEPSC(1) + DEPSC(2)*DEPSC(2) +
     1           DEPSC(4)*DEPSC(4)) + XCON2*(DEPSC(3)*DEPSC(3)))
C
      RETURN
C
      END
C *CDC* *DECK OVL37
C *CDC*      OVERLAY (ADINA,3,7)
C *CDC* *DECK EL2D12
C *UNI* )FOR,IS  N.EL2D12, R.EL2D12
C *CDC*      PROGRAM EL2D12
      SUBROUTINE EL2D12
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     M O D E L    =    12
C
      RETURN
      END
C *CDC* *DECK OVL38
C *CDC*      OVERLAY (ADINA,3,10)
C *CDC* *DECK EL2D13
C *UNI* )FOR,IS  N.EL2D13, R.EL2D13
C *CDC*      PROGRAM EL2D13
      SUBROUTINE EL2D13
C
C
C                         M O D E L  =  13
C
C     I N C O M P R E S S I B L E   E L A S T I C   M O D E L
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
C
      EQUIVALENCE (A(1),IA(1))
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE TODMFE
C
C
C     F I N D   S T R E S S - S T R A I N   L A W   A N D   S T R E S S
C
C
      MATP=IA(N107 + NEL - 1)
      NM=N109 + (MATP - 1)*2
      CALL MOONEY (NEL,A(NM),D,STRESS,STRAIN,IPT)
C
C
      RETURN
C
      END
C *CDC* *DECK MOONEY
C *UNI* )FOR,IS  N.MOONEY, R.MOONEY
      SUBROUTINE MOONEY (NEL,PROP,C,STRESS,STRAIN,IPT)
C
C
C     INCOMPRESSIBLE NONLINEAR ELASTIC MATERIAL
C         ( MOONEY-RIVLIN DESCRIPTION IN STATE OF PLANE STRESS )
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION PROP(1),STRAIN(1),STRESS(1),C(4,1)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /DISDER/DISD(5)
      DIMENSION CS(4)
      EQUIVALENCE (CS(1),CS11),(CS(2),CS22),(CS(3),CS12),(CS(4),CS33)
C
C
C
C
C     1.   DEFINE MATERIAL CONSTANTS
C
      C1=PROP(1)
      C2=PROP(2)
C
C     2.   CALCULATE DEFORMATION GRADIENT
C
      C11=2.*STRAIN(1) + 1.
      C12=STRAIN(3)
      C22=2.*STRAIN(2) + 1.
C
C     3. CALCULATE EXTENSION RATIO
C
      DENOM=C11*C22 - C12*C12
      EX2=1./DENOM
      EX4=EX2*EX2
      C1122=C11 + C22
C
C     4.   CALCULATE STRESSES
C
      T1=2.*(C1 + C2*EX2)
      T2=2.*(C1*EX4 - C2*(1. - EX4*C1122))
      STRESS(1)=T1 - T2*C22
      STRESS(2)=T1 - T2*C11
      STRESS(3)=T2*C12
      STRESS(4)=0.0
C
C     PRINT STRESSES
C
      IF (KPRI.NE.0) GO TO 10
      IF (IPRI.NE.0) GO TO 11
      IF (IPT.EQ.1 .AND. NEL.EQ.1) WRITE(6,2000)
      IF (IPT.NE.1) GO TO 11
      WRITE(6,2034) NEL
C
C     DISD   = DERIVATIVES OF DISPLACEMENTS WITH RESPECT TO
C              REFERENCE STATE COORDINATES
C
C     CALCULATE THE DEFORMATION GRADIENT
C
   11 X11=1.+DISD(1)
      X12=   DISD(3)
      X22=1.+DISD(2)
      X21=   DISD(4)
      X33=1.
C
C     DET    = (INITIAL DENSITY / CURRENT DENSITY)
C     INCOMPRESSIBILITY CONDITION YIELDS  DET=1.
C
      DET=1.
C
C     STRESS = 2ND PIOLA-KIRCHHOFF STRESSES
C
      S11=STRESS(1)
      S22=STRESS(2)
      S12=STRESS(3)
C
C     CS     = CAUCHY STRESSES
C
      CS11=DET * (S11*X11*X11 + 2.*S12*X11*X12 + S22*X12*X12)
      CS22=DET * (S11*X21*X21 + 2.*S12*X21*X22 + S22*X22*X22)
      CS12=DET * (S11*X11*X21 + S12*(X11*X22+X12*X21) + S22*X12*X22)
      CS33=0.
C
C     NOTE - ONLY CAUCHY STRESSES ARE ALWAYS PRINTED OR PLOTTED
C
      DO 14 I=1,4
   14 STRESS(I)=CS(I)
      IF (IPRI.NE.0) RETURN
C
   15 CALL MAXMIN (CS,P1,P2,AG)
      WRITE(6,2040) IPT,(CS(I),I=1,4),P1,P2,AG
C
C     RETURN IF STIFFNESS NOT TO BE CALCULATED
C
   10 IF (ICOUNT.GT.2) RETURN
      IF (IREF.NE.0) RETURN
C
C     5. CALCULATE STRESS-STRAIN MATRIX
C
      C1F=C1*EX4*4.
      C2F=C2*EX4*4.
      EC11=EX2*C11
      EC22=EX2*C22
      EC1=EC11*C1122
      EC2=EC22*C1122
      EC12=EC11*C22
C
      C(1,1)=2.*C22*(C1F*EC22 + C2F*(-1. + EC2))
      C(1,2)=C1F*(-1. + 2.*EC12) + C2F*(1./EX4 + 2.*C1122*(-1. + EC12))
      C(1,3)=C12*(-2.*C1F*EC22 + C2F*(1. - 2.*EC2))
      C(2,2)=2.*C11*(C1F*EC11 + C2F*(-1. + EC1))
      C(2,3)=C12*(-2.*C1F*EC11 + C2F*(1. - 2.*EC1))
      C(3,3)=(2.*C12*C12*EX2 + 0.5)*(C1F + C2F*C1122) - 2.*C2
      C(2,1)=C(1,2)
      C(3,1)=C(1,3)
      C(3,2)=C(2,3)
C
      RETURN
C
C
 2000 FORMAT (//24H  ELEMENT   INTEGRATION /19H  NUMBER      POINT ,4X,
     1        50H  SIGMA-X1  SIGMA-X2   TAU-X12  SIGMA-X3  SIGMA-P+,
     2        40H  SIGMA-P-  ANGLE                                /)
 2034 FORMAT (/I9)
 2040 FORMAT (9X,I10,4X,6E10.3,F7.2)
C
C
      END
C *CDC* *DECK OVL39
C *CDC*       OVERLAY (ADINA,3,9)
C *CDC* *DECK EL2D14
C *UNI* )FOR,IS  N.EL2D14, R.EL2D14
C *CDC*       PROGRAM EL2D14
      SUBROUTINE EL2D14
C
C     M O D E L   =   14      ( AUTHOR : YU.YU.WANG.XUAN )
C
C
C     ELASTOPLASTIC MODEL (MOHR OR PARABOLA - ELLIPSE)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /DPR/ ITWO
      COMMON A(1)
C
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (NPAR(10),NINT),(NPAR(17),NCON)
      EQUIVALENCE (A(1), IA(1))
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE TODMFE
C
C
      IDW=21*ITWO
      NPT=NINT*NINT
      MATP=IA(N107+NEL-1)
      NM=N109+(MATP-1)*NCON*ITWO
C
      IF(IND.NE.0) GO TO 100
C
C     INITIALIZE WA WORKING ARRAY
C
      NN=N110+(NEL-1)*NPT*IDW
C
      CALL IBAMMC (A(NN),A(NN),A(NM),NPT,IDW)
      GO TO 500
C
C     FIND STRESS-STRAIN LAW AND STRESSES
C
  100 NS=N110+((NEL-1)*NPT+(IPT-1))*IDW
      CALL BAMMC (A(NM),A(NS),A(NS+4*ITWO),A(NS+8*ITWO),A(NS+9*ITWO),
     1          A(NS+10*ITWO),A(NS+11*ITWO),A(NS+12*ITWO),A(NS+13*ITWO),
     2          A(NS+14*ITWO),A(NS+15*ITWO),A(NS+16*ITWO),A(NS+20*ITWO))
  500 CONTINUE
C
      RETURN
      END
C *CDC* *DECK IBAMMC
C *UNI* )FOR,IS  N.IBAMMC, R.IBAMMC
      SUBROUTINE IBAMMC (WA,IWA,PROP,NPT,IDW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DPR/ ITWO
      DIMENSION WA(21,1),IWA(IDW,1),PROP(1)
C
      NING=0
      IF(PROP(1).GT.0.5D0) NING=1
      NDIM=3
      IF(PROP(3).LT.0.5D0) NDIM=0
      NSEL=0
      IF(PROP(4).GT.0.5D0) NSEL=1
C
    5 FM=PROP(5)
      CM=PROP(6)
      CMI=CM
      SKA=PROP(8)
      SMOA=PROP(9)
      PEOA=PROP(10)
      SMA=PROP(11)
      SSA=PROP(12)
C
C
      IF(NDIM.EQ.3) GO TO 10
C
      SDKO=1-3*FM/(6+FM)
      IF(PROP(20).GT.1.0D-4) SDKO=PROP(20)
      SMM=SMOA*(1.+2.*SDKO)/3.
      SBAR=-SMOA*(1.-SDKO)
      ETA=-SBAR/SMM
      SMOA=SMM*(FM*FM+ETA*ETA)/FM/FM
      PEOA=PEOA-SKA*DLOG(SMOA/SMM)
      SMA=SMA*(1.+2.*SDKO)/3.
C
   10 ELO=-SMOA/2.
      IF(NING.NE.0) GO TO 12
      CHO=ELO*(FM-CM)
      GO TO 13
   12 HQO=PROP(14)
      CHO=HQO*HQO
   13 PEI=PEOA+SKA*DLOG(SMOA/SMA)
      HYM=PROP(16)
C
C     SET  STRESSES  AND  STRAINS  TO  INITIAL  VALUE
C     SET  INITIAL  STRESS  STATE  TO  *ELASTIC*
C
   15 DO 25 J=1,NPT
C
      WA(1,J)=SMA
      WA(2,J)=SMA
      WA(3,J)=SSA
      WA(4,J)=SMA
C
      DO 20 I=5,8
   20 WA(I,J)=0.
C
      WA(9,J)=CHO
      WA(10,J)=ELO
      WA(11,J)=PEOA
      WA(12,J)=CHO
      WA(13,J)=ELO
      WA(14,J)=PEI
      WA(15,J)=HYM
      WA(16,J)=CMI
C
      WA(17,J)=WA(1,J)
      WA(18,J)=WA(2,J)
      WA(19,J)=WA(3,J)
      WA(20,J)=WA(4,J)
      KJ=20*ITWO+1
   25 IWA(KJ,J)=1
C
      RETURN
      END
C *CDC* *DECK BAMMC
C *UNI* )FOR,IS  N.BAMMC,R.BAMMC
      SUBROUTINE BAMMC (PROP,SIG,EPS,CHO,ELO,PEO,CHI,ELI,PEI,HYM,CMI,
     1           WLNING,IPEL)
C
C
C
C     IST    NUMBER OF STRESS COMPONENTS
C     ISR    NUMBER OF STRAIN COMPONENTS
C     SIG    STRESS AT THE END OF PREVIOUS UPDATE
C     EPS    STRAIN AT THE END OF PREVIOUS UPDATE
C     RATIO  PART OF STRAIN INCREMENT TAKEN ELASTICALLY
C     DELEPS INCREMENT IN STRAINS
C     DELSIG INCREMENT IN STRESSES, ASSUMING ELASTIC BEHAVIOR
C
C
C     CHO    RADIUS OF CONE AT ORIGIN OF COORDINATES ON FIG.P-Q,UNDER
C            PRECONSOLIDATED PRESSURE
C     CHI    THE ABOVE RADIUS DURING STRAIN HARDENING
C     ELO    LENGTH OF HALF AXIS OF ELLIPSE ON HORIZONTAL AXIS ON FIG.
C            P-Q.UNDER PRECONSOLIDATED PRESSURE
C     ELI    ABOVE LENGTH DURING STRAIN HARDENING
C     PEO    VOID RATIO UNDER PRECONSOLIDATED PRESSURE
C     PEI    VOID RATIO DURING PRESSURE CHANGE
C     HYM    DRAINED YOUNGS MODULUS
C     CMI    RADIUS OF CONE ON FIG.P-Q IN PARA.
C
C
C     IPEL   =1   ELASTIC
C            =2   TENSION FAILURE
C            =3   PLASTIC FAILURE
C            =4   PLASTIC (PARA. OR MOHR)
C            =5   PLASTIC (ELLIPSOID)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /DISDER/ DISD(5)
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /BEIJIN/ A1,B1,C1,FM,CM,G,BK,SLMD,SKA,USKA,ISR,IST
C
      DIMENSION PROP(1),SIG(1),EPS(1),WLNING(1),STATE(5)
      DIMENSION TAU(4),TAUN(4),DELSIG(4),DELEPS(4),DEPS(4)
C
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(5),ITYP2D),(DELEPS(1),DEPS(1))
      EQUIVALENCE (NPAR(17),NCON)
C
      DATA NGLAST/1000/,STATE/7HELASTIC,7HTENSILE,7HSHEARED,7HP--MOHR,
     1     7HP---CAP/
C
C
      IF(IPT.NE.1) GO TO 116
      IF(ITYP2D.LT.2) GO TO 100
      WRITE(6,3000)
      STOP
C
  100 IST=4
      ISR=3
      IF(ITYP2D.EQ.0) ISR=4
C
      NING=0
      IF(PROP(1).GT.0.5D0) NING=1
      NHARD=1
      IF(PROP(2).LT.0.5D0) NHARD=0
      NSEL=0
      IF(PROP(4).GT.0.5D0) NSEL=1
C
  105 FM=PROP(5)
      CM=PROP(6)
      IF(NING.NE.1) GO TO 107
      CM=(-CHO+FM*FM*ELO*ELO)/ELO
      APEX=CHO/CM
  107 SLMD=PROP(7)
      SKA=PROP(8)
      NOCAP=0
      FH=SLMD-SKA
      IF(FH.LT.1.0D-6) NOCAP=1
      PAR=PROP(13)
      HQO=PROP(14)
      USKA=0.1D-2
      IF(PROP(15).GT.0.1D-2) USKA=PROP(15)
      PV=PROP(17)
C
  110 YM=HYM
      PN=PV
      SKAN=SKA
C
      IF(NSEL.NE.1) GO TO 112
      G=PROP(19)
      BK=PROP(18)
      GO TO 115
  112 G=YM/(1.+PN)/2.
      BK=YM/(1.-2.*PN)/3.
C
  115 A1=BK+4.*G/3.
      B1=BK-2.*G/3.
      C1=G
C
  116 CHT=CHI
      ELT=ELI
      PET=PEI
      CMT=CMI
C
C        1.  CALCULATE STRAIN INCREMENT
C
      IF(IPEL.NE.2.AND.IPEL.NE.3) GO TO 119
      DO 117 I=1,IST
  117 TAU(I)=SIG(I)
      GO TO 610
C
  119 DO 120 I=1,ISR
  120 DELEPS(I)=STRAIN(I)-EPS(I)
C
C        2.  CALCULATE STRESS INCREMENT,
C            ASSUMING ELASTIC BEHAVIOR
C
      DELSIG(1)=A1*DELEPS(1)+B1*DELEPS(2)
      DELSIG(2)=B1*DELEPS(1)+A1*DELEPS(2)
      DELSIG(3)=C1*DELEPS(3)
      DELSIG(4)=B1*(DELEPS(1)+DELEPS(2))
      IF(ITYP2D.EQ.1) GO TO 125
      DELSIG(1)=DELSIG(1)+B1*DELEPS(4)
      DELSIG(2)=DELSIG(2)+B1*DELEPS(4)
      DELSIG(4)=DELSIG(4)+A1*DELEPS(4)
C
C       3.  CALCULATE TOTAL STRESSES,
C           ASSUMING ELASTIC BEHAVIOR
C
  125 DO 130 I=1,IST
  130 TAU(I)=SIG(I)+DELSIG(I)
C
C       4.  CHECK WHETHER *TAU* STATE OF STRESS FALLS OUTSIDE
C           THE LOADING SURFACE
C
C       4-1. CHECK WHETHER *TAU* OUTSIDE THE CONE
C
      SM=(TAU(1)+TAU(2)+TAU(4))/3.
      SX=TAU(1)-SM
      SY=TAU(2)-SM
      SS=TAU(3)
      SZ=TAU(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
C
      XSM=SM+ELT
      SMG=(SIG(1)+SIG(2)+SIG(4))/3.0
      FHM=XSM/CHO
      FHG=(SMG+ELT)/CHO
      IF(FHM.LT.-1.D-3.AND.FHG.LT.-1.D-3) GO TO 195
C
      FCT=CM*SM+SBAR-CHT
      IF(NING.EQ.1) FCT=CMT*SM+SBAR*SBAR-CHT
      IF(FCT.LT.0.0) GO TO 180
      IF(FCT.LT.1.D-7) GO TO 175
C
C            *TAU* OUTSIDE *CONE* CORRECTING *TAU*
C
      RATIO=0.0
      IF(IPEL.EQ.4) GO TO 140
      SM=SMG
      SX=SIG(1)-SM
      SY=SIG(2)-SM
      SS=SIG(3)
      SZ=SIG(4)-SM
C
      DM=(DELSIG(1)+DELSIG(2)+DELSIG(4))/3.
      DX=DELSIG(1)-DM
      DY=DELSIG(2)-DM
      DS=DELSIG(3)
      DZ=DELSIG(4)-DM
C
      IF (NING.NE.1) GO TO 131
C
      A=DX*DX+DY*DY+2.*DS*DS+DZ*DZ
      B=SX*DX+SY*DY+SZ*DZ+2.*SS*DS+2.*CMT*DM/3.0
      E=SX*SX+SY*SY+SZ*SZ+2.*SS*SS+2.*(CMT*SM-CHT)/3.0
      GO TO 135
C
  131 A=DX*DX+DY*DY+2.*DS*DS+DZ*DZ-2.*CM*CM*DM*DM/3.
      B=SX*DX+SY*DY+2.*SS*DS+SZ*DZ+2.*CM*DM*(CHT-CM*SM)/3.
      E=SX*SX+SY*SY+2.*SS*SS+SZ*SZ+2.*CM*SM*(2.*CHT-CM*SM)/3.-2.*CHT*CHT
     1  /3.
      IF(A) 135,132,135
  132 RATIO=-E/2.0/B
      GO TO 140
C
  135 RATO=B*B-A*E
      IF(RATO.LT.1.D-7) RATO=0.0
      RATIO=(-B+DSQRT(RATO))/A
  140 CONTINUE
C
      DO 145 I=1,IST
  145 TAU(I)=SIG(I)+RATIO*DELSIG(I)
C
      SM=(TAU(1)+TAU(2)+TAU(4))/3.
C
      FH=(SM+ELT)/CHO
      IF(NING.EQ.1) FH=(SM+ELT)/HQO
C
      IF(FH.LT.-1.D-4) GO TO 186
      IF(FH.GT.1.D-4) GO TO 155
C
  150 IPEL=3
      IF(NHARD.EQ.1) PET=PEO+0.693147*SKAN
      GO TO 610
C
  155 IPEL=4
      IF(SM.LT.-10D-8.AND.SMG.LT.-10D-8) GO TO 160
      PET=5.55D0
      GO TO 165
C
  160 IF(SMG-SM) 161,165,162
  161 PET=PET+SKAN*DLOG(SMG/SM)
      GO TO 165
  162 PET=PET-SKAN*DLOG(SM/SMG)
C
  165 SKAN=USKA
      IF(NHARD.EQ.0) GO TO 170
      NHARD=0
C
  170 DH=FCT
      SBARO=CHO
      IF(NING.EQ.1) SBARO=HQO
      GO TO 270
C
  175 FH=XSM/CHO
      IF(NING.EQ.1) FH=XSM/HQO
      IF(FH.LT.-1.D-4) GO TO 195
      IF(FH.GT.1.D-4) GO TO 181
      GO TO 150
C
  180 IF(XSM) 195,195,181
C
  181 IPEL=1
      IF(SM.LT.-10D-8.AND.SMG.LT.-10D-8) GO TO 182
      PET=5.55D0
      GO TO 610
C
  182 IF(SMG-SM) 183,185,184
  183 PET=PET+SKAN*DLOG(SMG/SM)
      GO TO 610
  184 PET=PET-SKAN*DLOG(SM/SMG)
  185 GO TO 610
C
  186 IF(NOCAP.EQ.1) GO TO 155
      SX=TAU(1)-SM
      SY=TAU(2)-SM
      SS=TAU(3)
      SZ=TAU(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
      ETA=-SBAR/SM
      DH=-0.5*(FM-CM)*(SM*(1.+ETA*ETA/FM/FM)+2.*ELI)+FCT
      IF(NING.EQ.1) DH=DH*(FM-CMT)/(FM-CM)
      GO TO 205
C
C       4-2. CHECK WHETHER *TAU** OUTSIDE THE ELLIPSOID
C
  195 SMT=-2.*ELI
      ETA=-SBAR/SM
C
      FRT=(SLMD-SKAN)*DLOG(SM*(1.D0+ETA*ETA/FM/FM)/SMT)
C
      IF(NOCAP.EQ.1) FRT=0.0
C
      IF(FRT) 181,181,200
C
C         *TAU* OUTSIDE *ELLIPSOID* CORRECTING *TAU*
C         DETERRMINE PART OF STRAIN TAKEN ELASTICLY
C
  200 DH=-0.5*(FM-CM)*(SM*(1.+ETA*ETA/FM/FM)-SMT)
      IF(NING.EQ.1) DH=DH*(FM-CMT)/(FM-CM)
  205 RATIO=0.0
      IF(IPEL.EQ.5) GO TO 210
      IPEL=5
      SM=SMG
      SX=SIG(1)-SM
      SY=SIG(2)-SM
      SS=SIG(3)
      SZ=SIG(4)-SM
C
      DM=(DELSIG(1)+DELSIG(2)+DELSIG(4))/3.
      DX=DELSIG(1)-DM
      DY=DELSIG(2)-DM
      DS=DELSIG(3)
      DZ=DELSIG(4)-DM
C
      A=DX*DX+DY*DY+2.*DS*DS+DZ*DZ+2.*FM*FM*DM*DM/3.
      B=SX*DX+SY*DY+2.*SS*DS+SZ*DZ+2.*FM*FM*DM*(SM+ELT)/3.
      E=SX*SX+SY*SY+2.*SS*SS+SZ*SZ+2.*FM*FM*SM*(SM+2.*ELT)/3.
C
      IF(A) 208,206,208
  206 RATIO=-E/2.0/B
      GO TO 210
  208 RATO=B*B-A*E
      IF(RATO.LT.1.D-7) RATO=0.D0
      RATIO=(-B+DSQRT(RATO))/A
  210 CONTINUE
C
      DO 220 I=1,IST
  220 TAU(I)=SIG(I)+RATIO*DELSIG(I)
C
C         *TAU* NOW CONTAINS (PREVIOUS STRESSES + STRESSES DUE TO
C                             ELASTIC STRAIN INCREMENTS )
C
      SM=(TAU(1)+TAU(2)+TAU(4))/3.
      SX=TAU(1)-SM
      SY=TAU(2)-SM
      SS=TAU(3)
      SZ=TAU(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
      ETA=-SBAR/SM
C
      SBARO=2.*ELO*(FM*FM*ETA/(FM*FM+ETA*ETA))
C
      IF(NHARD.EQ.0) GO TO 270
      IF(SM.LT.-10D-8.AND.SMG.LT.-10D-8) GO TO 240
      PET=5.55D0
      GO TO 270
C
  240 IF(SMG-SM) 250,270,260
  250 PET=PET+SKAN*DLOG(SMG/SM)
      GO TO 270
  260 PET=PET-SKAN*DLOG(SM/SMG)
C
C         DETERMINE INCREMENT INTERVAL
C
  270 IF(DH.LT.1.D-7) DH=0.0
      M=20.*DSQRT(2.D0*SBARO*DH)/SBARO+1.
      IF(M.GT.30) M=30
      XM=(1.-RATIO)/DBLE(FLOAT(M))
C
C       5.  CALCULATION OF ELASTOPLASTIC STRESSES...(START)
C
      DO 280 I=1,ISR
  280 DEPS(I)=XM*DELEPS(I)
C
      DO 600 IM=1,M
C
      IF(IPEL.NE.5) GO TO 290
      CALL ELLIPS (TAU,DEPS,NHARD,PEO,PAR)
      GO TO 300
C
  290 CALL CURVE  (TAU,DEPS,CMT,NING)
C
  300 CONTINUE
      DO 310 I=1,IST
      TAUN(I)=TAU(I)
      DO 310 J=1,ISR
  310 TAU(I)=TAU(I)+C(I,J)*DEPS(J)
C
      SM=(TAUN(1)+TAUN(2)+TAUN(4))/3.
      DM=(TAU(1)+TAU(2)+TAU(4))/3.
C
C       5-1.CORRECTION OF STESSES
C
      IF(IPEL.NE.5) GO TO 330
      DX=TAU(1)-DM
      DY=TAU(2)-DM
      DS=TAU(3)
      DZ=TAU(4)-DM
      DSBAR=DSQRT(1.5D0*(DX*DX+DY*DY+DZ*DZ+2.D0*DS*DS))
      DETA=-DSBAR/DM
C
      SX=TAUN(1)-SM
      SY=TAUN(2)-SM
      SS=TAUN(3)
      SZ=TAUN(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
      ETA=-SBAR/SM
C
  330 IF(NHARD.EQ.1) GO TO 350
C
      FH=DABS(DH)/CHO
      IF(NING.EQ.1) FH=DABS(DH)/HQO
      IF(FH.LT.0.005D0) GO TO 350
C
      IF(IPEL.NE.5) GO TO 340
      CALL PLACAP (TAU,DM,DSBAR,DETA,ELT)
      GO TO 350
C
  340 CALL PARABO (TAU,DM,CHT,CMT,NING)
  350 CONTINUE
C
C       5-2.JUDGEMENT AND TREATMENT OF FAILURE
C
      IF(IPEL.NE.5) GO TO 400
C
      FH=FM-DETA
      IF(FH.GE.0.0.AND.DM.LE.-10D-6) GO TO 360
C
      DO 355 I=1,IST
  355 TAU(I)=TAUN(I)
      DETA=ETA
      DM=SM
      GO TO 450
C
  360 IF(NHARD.EQ.0) GO TO 365
      IF(IM.EQ.M) GO TO 365
C
      SMT=-2.*ELT
      DSMT=DM*(1.+DETA*DETA/FM/FM)
C
      FRT=(SLMD-SKAN)*DLOG(DSMT/SMT)
      ELT=ELT*DEXP(FRT/(SLMD-SKA))
      CHT=(FM-CM)*ELT
      IF(NING.NE.1) GO TO 361
      CMT=FM*FM*ELT*ELT/(ELT+APEX)
      CHT=APEX*CMT
C
  361 IF(SM-DM) 363,364,364
  363 PET=PET-FRT+SKAN*DLOG(SM/DM)
      GO TO 365
  364 PET=PET-FRT-SKAN*DLOG(DM/SM)
C
  365 IF(FH) 450,450,600
C
  400 IF(NOCAP.EQ.1) GO TO 420
      IF(DM+ELT) 410,450,420
C
  410 DO 415 I=1,IST
  415 TAU(I)=TAUN(I)
      GO TO 450
C
  420 IF(DM.LT.0.0) GO TO 600
C
      XSM=DM-SM
      IF(XSM.LE.0.) GO TO 600
C
      CBT=CHT/CM
      IF (NING.EQ.1) CBT=APEX
      FH=(CBT-DM)/XSM
      IF(FH.GE.1.D0) GO TO 600
      PET=8.88D0
      IPEL=2
      GO TO 610
C
  450 IPEL=3
      GO TO 610
C
  600 CONTINUE
C
C       CALCULATION OF ELASTOPLASTIC STRESSES...(END)
C
  610 DO 620 I=1,IST
  620 STRESS(I)=TAU(I)-WLNING(I)
C
C     6.UPDATING PEI,SIG,EPS,CHI,ELI
C
  625 IF(IUPDT.NE.0) GO TO 650
      DO 630 I=1,IST
  630 SIG(I)=TAU(I)
      DO 640 I=1,ISR
  640 EPS(I)=STRAIN(I)
C
      PEI=PET
C
      IF(IPEL.EQ.1) GO TO 650
      IF(NHARD.EQ.0) GO TO 650
C
      PEO=PET
      CHI=CHT
      ELI=ELT
      CMI=CMT
C
  650 COHE=CHT
      IF(NING.EQ.1) COHE=DSQRT(CHT)
      IF(KPRI.EQ.0) GO TO 700
C
      IF(ICOUNT.EQ.3) RETURN
C
C       7.  FORM NEW MATERIAL LAW
C
      IF(IEQREF.EQ.1) GO TO 655
      GO TO (655,675,675,685,695), IPEL
C
C           ELASTIC
C
  655 DO 660 I=1,ISR
      DO 660 J=1,ISR
  660 C(I,J)=0.0
      C(1,1)=A1
      C(2,1)=B1
      C(1,2)=B1
      C(2,2)=A1
      C(3,3)=C1
      IF(ITYP2D.EQ.1) RETURN
      C(1,4)=B1
      C(2,4)=B1
      C(4,1)=B1
      C(4,2)=B1
      C(4,4)=A1
      RETURN
C
C        ELASTO-PLASTIC
C
C
  675 DO 680 I=1,ISR
      DO 680 J=1,ISR
      C(I,J)=0.0
      IF(J.EQ.I) C(I,J)=1.0D0
  680 CONTINUE
      RETURN
C
  685 CALL CURVE (TAU,DEPS,CMT,NING)
      RETURN
C
  695 CALL ELLIPS (TAU,DEPS,NHARD,PEO,PAR)
      RETURN
C
C         PRINTING OF STRESS
C
  700 IF(IPEL.EQ.1) GO TO 800
C
      DM=(TAU(1)+TAU(2)+TAU(4))/3.
      DX=TAU(1)-DM
      DY=TAU(2)-DM
      DS=TAU(3)
      DZ=TAU(4)-DM
      SBAR=DSQRT(1.5D0*(DX*DX+DY*DY+DZ*DZ+2.D0*DS*DS))
      SMT=-2.*ELT
      ETA=-SBAR/DM
C
      IF (IPEL-4) 800,730,750
C
  730 FT=CM*DM+SBAR-CHT
      IF (NING.EQ.1) FT=CMT*DM+SBAR*SBAR-CHT
      GO TO 800
C
  750 FT=(SLMD-SKAN)*DLOG(DM*(1.D0+ETA*ETA/FM/FM)/SMT)
C
  800 IF (IPRI.NE.0) RETURN
C
      CALL MAXMIN (TAU,SX,SY,SM)
      SINV=(TAU(1)+TAU(2)+TAU(4))/3.
      EFSG=DSQRT(1.5D0*((TAU(4)-SINV)**2+(TAU(1)-SINV)**2+(TAU(2)
     1           -SINV)**2+2.D0*TAU(3)*TAU(3)))
      EINV=STRAIN(1)+STRAIN(2)+STRAIN(4)
      QEFPE=(STRAIN(1)-STRAIN(2))**2+(STRAIN(2)-STRAIN(4))**2
     1     +(STRAIN(4)-STRAIN(1))**2+1.5*STRAIN(3)*STRAIN(3)
      EFPE=DSQRT(QEFPE/2.0D0)/(1.0+PN)
C
      IF (IPS.LT.0) GO TO 900
C
C     STRESS PRINTOUT ONLY **
C
      IF (IPT.GT.1) GO TO 850
C
C     PRINT HEADING *
C
      WRITE (6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE (6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES *
C
  850 WRITE (6,2100) IPT,STATE(IPEL),TAU(4),(TAU(J),J=1,3),
     1               SX,SY,SM
      WRITE (6,2200) IPEL,EFSG,COHE,FT
C
      RETURN
C
C     STRESS AND STRAIN PRINTOUT **
C
  900 IF (IPT.GT.1) GO TO 920
C
C     PRINT HEADING *
C
      WRITE (6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE (6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES AND STRAINS *
C
  920 WRITE (6,2100) IPT,STATE(IPEL),TAU(4),(TAU(J),J=1,3),
     1               SX,SY,SM
      WRITE (6,2400) STRAIN(4),(STRAIN(J),J=1,3)
      WRITE (6,2500) EINV,EFPE,PEI
      WRITE (6,2200) IPEL,EFSG,COHE,FT
C
      RETURN
C
 2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,
     1        13X,2HYY,13X,2HZZ,13X,2HYZ,9X,10HMAX STRESS,5X,
     2        10HMIN STRESS,3X,5HANGLE,/,1X,7HNUM/IPT,3X,5HSTATE,4X,
     3        10HCOMPONENTS)
 2005 FORMAT (/,1X,I3)
 2100 FORMAT (4X,I2,4X,A7,3X,6HSTRESS,9X,6(E14.6,1X),F6.2)
 2200 FORMAT (20X,7HIPEL = ,I2,2X,14HDEVI-STRESS = ,E14.6,2X,
     1        7HCOHE = ,E14.6,2X,17HYIELD FUNCTION = , E14.6,/)
 2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,4(E14.6,1X))
 2500 FORMAT (20X,15HVOLUM STRAIN = ,E14.6,2X,14HDEVI-STRAIN = ,E14.6,
     1        2X,13HVOID RATIO = , E14.6,/)
 3000 FORMAT (44H   ERROR   NOT CONSIDER CASE OF PLANE STRESS   )
      END
C *CDC* *DECK CURVE
C *UNI* )FOR,IS  N.CURVE, R.CURVE
      SUBROUTINE CURVE (TAU,DEPS,CMT,NING)
C
C     THIS SUBRORTING FORMS THE ELASTO-PLASTIC MATERIAL LAW
C     FOR THE PARA.OR.MOHR YIELD SURFACE (IPEL=4)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /BEIJIN/ A1,B1,C1,FM,CM,G,BK,SLMD,SKA,USKA,ISR,IST
C
      DIMENSION DP(16),TAU(1),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),DP(1))
C
      SM=(TAU(1)+TAU(2)+TAU(4))/3.
      SX=TAU(1)-SM
      SY=TAU(2)-SM
      SS=TAU(3)
      SZ=TAU(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
C
      E=CM/3.
      R=1.5/SBAR
      IF (NING.NE.1) GO TO 10
      E=CMT/3.0
      R=3.0D0
C
   10 FX=E+R*SX
      FY=E+R*SY
      FS=2.*R*SS
      FZ=E+R*SZ
C
      DX=3.*BK*E+2.*G*R*SX
      DY=3.*BK*E+2.*G*R*SY
      DS=2.*G*R*SS
      DZ=3.*BK*E+2.*G*R*SZ
C
   15 W=DX*FX+DY*FY+DS*FS+DZ*FZ
C
      IF (ITYP2D.LT.1) GO TO 20
C
      DLAMDA=(DX*DEPS(1)+DY*DEPS(2)+DS*DEPS(3))/W
      GO TO 25
C
   20 DLAMDA=(DX*DEPS(1)+DY*DEPS(2)+DS*DEPS(3)+DZ*DEPS(4))/W
C
   25 IF(DLAMDA.GT.0.) GO TO 30
C
      DX=0.
      DY=0.
      DS=0.
      DZ=0.
C
   30 DP(1)=A1-DX*DX/W
      DP(2)=B1-DX*DY/W
      DP(3)=-DX*DS/W
      DP(4)=B1-DX*DZ/W
      DP(5)=DP(2)
      DP(6)=A1-DY*DY/W
      DP(7)=-DY*DS/W
      DP(8)=B1-DY*DZ/W
      DP(9)=DP(3)
      DP(10)=DP(7)
      DP(11)=C1-DS*DS/W
      DP(12)=-DS*DZ/W
C
      IF (ITYP2D.EQ.1) RETURN
C
      DP(13)=DP(4)
      DP(14)=DP(8)
      DP(15)=DP(12)
      DP(16)=A1-DZ*DZ/W
C
      RETURN
      END
C *CDC* *DECK ELLIPS
C *UNI* )FOR,IS  N.ELLIPS  R.ELLIPS
      SUBROUTINE ELLIPS (TAU,DEPS,NHARD,PEO,PAR)
C
C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
C     FOR THE ELLIPSE YIELD CAP(IPEL=5)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /BEIJIN/ A1,B1,C1,FM,CM,G,BK,SLMD,SKA,USKA,ISR,IST
C
      DIMENSION DP(16),TAU(1),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),DP(1))
C
      SM=(TAU(1)+TAU(2)+TAU(4))/3.0
      SX=TAU(1)-SM
      SY=TAU(2)-SM
      SS=TAU(3)
      SZ=TAU(4)-SM
      SBAR=DSQRT(1.5D0*(SX*SX+SY*SY+SZ*SZ+2.D0*SS*SS))
      ETA=-SBAR/SM
C
      SKAN=SKA
      IF (NHARD.EQ.0) SKAN=USKA
C
      R=(SLMD-SKAN)/SM
      E=R*(FM*FM-ETA*ETA)/(FM*FM+ETA*ETA)/3.
      R=3.*R/(FM*FM+ETA*ETA)/SM
C
      FX=E+R*SX
      FY=E+R*SY
      FS=2.*R*SS
      FZ=E+R*SZ
C
      DX=3.*BK*E+2.*G*R*SX
      DY=3.*BK*E+2.*G*R*SY
      DS=2.*G*R*SS
      DZ=3.*BK*E+2.*G*R*SZ
C
      W=DX*FX+DY*FY+DS*FS+DZ*FZ
      A=-3.*E*(1.+PEO)
      IF(NHARD.EQ.0) A=0.0
      W=A+W
C
      IF (ITYP2D.LT.1) GO TO 20
C
      DLAMDA=(DX*DEPS(1)+DY*DEPS(2)+DS*DEPS(3))/W
      GO TO 25
C
   20 DLAMDA=(DX*DEPS(1)+DY*DEPS(2)+DS*DEPS(3)+DZ*DEPS(4))/W
   25 IF (DLAMDA.GT.0.0) GO TO 30
C
      DX=0.
      DY=0.
      DS=0.
      DZ=0.
C
   30 DP(1)=A1-DX*DX/W
      DP(2)=B1-DX*DY/W
      DP(3)=-DX*DS/W
      DP(4)=B1-DX*DZ/W
      DP(5)=DP(2)
      DP(6)=A1-DY*DY/W
      DP(7)=-DY*DS/W
      DP(8)=B1-DY*DZ/W
      DP(9)=DP(3)
      DP(10)=DP(7)
      DP(11)=C1-DS*DS/W
      DP(12)=-DS*DZ/W
C
      IF(ITYP2D.EQ.1) RETURN
C
      DP(13)=DP(4)
      DP(14)=DP(8)
      DP(15)=DP(12)
      DP(16)=A1-DZ*DZ/W
C
      RETURN
      END
C *CDC* *DECK PARABO
C *UNI* )FOR,IS  N.PARABO, R.PARABO
      SUBROUTINE PARABO (TAU,DM,CHT,CMT,NING)
C
C     THIS SUBROUTINE CORRECTS STRESS FOR PERFECTLY PLASTIC CASE
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /BEIJIN/ A1,B1,C1,FM,CM,G,BK,SLMD,SKA,USKA,ISR,IST
C
      DIMENSION TAU(1)
C
      DX=TAU(1)-DM
      DY=TAU(2)-DM
      DS=TAU(3)
      DZ=TAU(4)-DM
C
      SBAR=DSQRT(1.5D0*(DX*DX+DY*DY+DZ*DZ+2.D0*DS*DS))
C
      IF (NING.EQ.1) GO TO 25
      AA=2.25-CM*CM*CM*CM/9.
      BB=3.*SBAR-2.*CM*CM*(CM*DM-CHT)/3.0
      CC=SBAR*SBAR-CM*DM*(CM*DM-2.*CHT)-CHT*CHT
C
      IF(AA) 20,10,20
   10 PP=CC/BB
      GO TO 30
   20 PP=(BB-DSQRT(BB*BB-4.D0*AA*CC))/AA/2.0
      GO TO 30
C
   25 AA=SBAR*SBAR
      BB=6.*AA+CM*CM/3.
      CC=AA+CM*DM-CHT
      AA=9.*AA
      PP=(BB-DSQRT(BB*BB-4.D0*AA*CC))/AA/2.0
C
   30 CC=CM/3.0
      R=1.5/SBAR
      IF(NING.NE.1) GO TO 40
      CC=CMT/3.0
      R=3.0D0
C
   40 TAU(1)=TAU(1)-PP*(CC+R*DX)
      TAU(2)=TAU(2)-PP*(CC+R*DY)
      TAU(3)=TAU(3)-PP*R*DS
      TAU(4)=TAU(4)-PP*(CC+R*DZ)
C
      DM=(TAU(1)+TAU(2)+TAU(4))/3.0
C
      RETURN
      END
C *CDC* *DECK PLACAP
C *UNI* )FOR,IS  N.PLACAP,R.PLACAP
      SUBROUTINE PLACAP (TAU,DM,SBAR,ETA,ELT)
C
C     THIS SUBROUTINE CORRECTS STRESS FOR PERFECTLY PLASTIC CASE
C          (FOR ELLIPSE-CAP YIELD SURFACE)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /BEIJIN/ A1,B1,C1,FM,CM,G,BK,SLMD,SKA,USKA,ISR,IST
C
      DIMENSION TAU(1)
C
      DX=TAU(1)-DM
      DY=TAU(2)-DM
      DS=TAU(3)
      DZ=TAU(4)-DM
C
      R=(SLMD-USKA)/DM
      E=R*(FM*FM-ETA*ETA)/(FM*FM+ETA*ETA)/3.0
      R=3.0*R/(FM*FM+ETA*ETA)/DM
C
      A=R*R*SBAR*SBAR+E*E*FM*FM
      B=R*SBAR*SBAR+FM*FM*E*(DM+ELT)
      P=SBAR*SBAR+FM*FM*DM*(DM+2.0*ELT)
C
      IF(A) 20,10,20
   10 P=B/2.0/P
      GO TO 30
   20 PP=B*B-A*P
      IF(PP.LE.0.0001) PP=0.D0
      P=(B-DSQRT(PP))/A
   30 IF(P.LT.1.0D-8) RETURN
C
      TAU(1)=TAU(1)-P*(E+R*DX)
      TAU(2)=TAU(2)-P*(E+R*DY)
      TAU(3)=TAU(3)-P*R*DS
      TAU(4)=TAU(4)-P*(E+R*DZ)
C
      DM=(TAU(1)+TAU(2)+TAU(4))/3.0
      DX=TAU(1)-DM
      DY=TAU(2)-DM
      DS=TAU(3)
      DZ=TAU(4)-DM
C
      SBAR=DSQRT(1.5D0*(DX*DX+DY*DY+DZ*DZ+2.0D0*DS*DS))
C
      ETA=-SBAR/DM
C
      RETURN
      END
C *CDC*  *DECK  OVLN39
C *CDC*         OVERLAY (ADINA,3,12)
C *CDC*  *DECK  EL2D15
C *UNI*  )FOR,IS N.EL2D15 , R.EL2D15
C *CDC*         PROGRAM EL2D15
      SUBROUTINE  EL2D15
C
C     MODEL = 15-16
C
      IMPLICIT REAL*8 (A-H,O-Z)
      RETURN
      END
C *CDC* *DECK OVL40
C *CDC*       OVERLAY (ADINA,4,0)
C *CDC* *DECK THREDM
C *UNI* )FOR,IS  N.THREDM, R.THREDM
C *CDC*       PROGRAM THREDM
      SUBROUTINE THREDM
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   M A T E R I A L  M O D E L S                                    .
C .                                                                   .
C .   MODEL =  1   LINEAR ISOTROPIC                                   .
C .            2   LINEAR ORTHOTROPIC                                 .
C .            3   LINEAR THERMOELASTIC MODEL                         .
C .            4   NONLINEAR CURVE DESCRIPTION MODEL                  .
C .            5   CONCRETE STRUCTURE MODEL                           .
C .            7   ELASTIC-PLASTIC (DRUCKER-PRAGER WITH CAP)
C .            8   ELASTIC PLASTIC (VON MISES/ISOTROPIC HARDENING)    .
C .            9   ELASTIC PLASTIC (VON MISES/KINEMATIC HARDENING)    .
C .           10   ELASTIC PLASTIC, CREEP (ISOTROPIC HARDENING)       .
C .           11   ELASTIC PLASTIC, CREEP (KINEMATIC HARDENING)       .
C .                                                                   .
C .   S T O R A G E                                                   .
C .                                                                   .
C .         N101   LM ARRAY (ELEMENT CONNECTIVITY)                    .
C .         N102   XYZ ARRAY (ELEMENT COORDINATES)                    .
C .                                                                   .
C .         N103   IELTD                                              .
C .         N104   IELTX                                              .
C .         N105   IPST                                               .
C .         N106   ISO (SPATIAL ISOTROPY CORRECTION INDICATOR)        .
C .         N107   MATP                                               .
C .         N108   NOD9 (MIDSIDE NODES LOCATION ARRAY)                .
C .         N109   IREUSE                                             .
C .                                                                   .
C .         N110   DEN                                                .
C .         N111   PROP (MATERIAL CONSTANTS)                          .
C .         N112   WA (WORKING ARRAY)                                 .
C .         N113   ETIMV (ELEMENT EXPIRY TIME ARRAY, IF IDEATH EQ. 1) .
C .         N114   EDISB (ELEMENT BIRTH-TIME NODAL COORDINATES)       .
C .         N115   ITABLE (STRESS OUTPUT LOCATION TABLES)             .
C .         N116   DCA (DIRECTION COSINE ARRAY, IF MODEL EQ.2)        .
C .         N117   MAXESV (MATERIAL AXIS ORIENTATION STORAGE VECTOR)  .
C .         N119   PDIS (DISPLACEMENTS AT PREVIOUS STEP)              .
C .                                                                   .
C .         N120   S (ELEMENT STIFFNESS MATRIX)                       .
C .         N121   XM                                                 .
C .         N122   B (COMPACTED STRAIN-DISPLACEMENT MATRIX)           .
C .         N123   RE                                                 .
C .         N124   EDIS                                               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /DPR/ ITWO
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /SKEW  / NSKEWS
      COMMON /ELSTP / TIME,IDTHF
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /PRSHAP/ KSHAPE
      COMMON /ULJ/ IULJ
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      DIMENSION NMCON(20),IDWAS(20),NDWS(20),DATA(20)
C
      EQUIVALENCE (NPAR(2),NUME), (NPAR(3),INDNL), (NPAR(4),IDEATH),
     1            (NPAR(6),NEGSKS), (NPAR(7),MXNODS), (NPAR(10),NINT),
     2            (NPAR(11),NINTZ), (NPAR(13),NTABLE), (NPAR(15),MODEL),
     3            (NPAR(16),NUMMAT), (NPAR(17),NCON), (NPAR(18),NORTHO),
     2            (NPAR(19),ITHERM), (NPAR(1),NPAR1), (NPAR(8),IDEGEN)
C
      DATA RECLB1 /8HTYPE-3  /
C
      DATA NMCON / 2, 9,66,28,38, 0, 8, 4, 4,113,113, 9*0/,
     1     IDWAS / 0, 0, 0,22,22, 0,14,21,21, 47, 47, 9*0/,
     2     NDWS  / 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 9*0/
C
C
C
      IULJ=0
      IF (INDNL.EQ.3 .AND. MODEL.EQ.8) IULJ=1
      IF (IND.NE.0) GO TO 100
      IF (IDEGEN.GT.0) KSHAPE=1
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   I N P U T   P H A S E                                           .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C     CHECK ON RANGE AND SET DEFAULTS FOR NPAR VECTOR
C
      ISTOP=0
      MODMAX=12
C
      IF (NUME.GT.0) GO TO 10
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=2
      IRANGE=1
      WRITE (6,2400) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   10 IF (INDNL.GE.0 .AND. INDNL.LE.3) GO TO 15
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=3
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
      INMIN=0
      INMAX=3
      WRITE (6,2250) ISUB,INMIN,INMAX
C
   15 IF (IDEATH.NE.0) IDTHF=1
      IF (IDEATH.GE.0 .AND. IDEATH.LE.2) GO TO 25
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=4
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
      INMIN=0
      INMAX=2
      WRITE (6,2250) ISUB,INMIN,INMAX
C
   25 IF (MXNODS.LE.0) MXNODS=21
      IF (MXNODS.LE.21) GO TO 28
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=7
      IRANGE=21
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   28 IF (IDEGEN.GE.0 .AND. IDEGEN.LE.1) GO TO 30
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=8
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
      INMIN=0
      INMAX=1
      WRITE (6,2250) ISUB,INMIN,INMAX
C
   30 IF (NINT.LE.0) NINT=2
      IF (NINT.LE.4) GO TO 32
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=10
      IRANGE=4
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   32 IF (NINTZ.LE.0) NINTZ=2
      IF (NINTZ.LE.4) GO TO 35
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=11
      IRANGE=4
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   35 IF (MODEL.LE.0) MODEL=1
      IF (MODEL.LE.MODMAX) GO TO 40
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=15
      WRITE (6,2300) ISTOP,ISUB,MODMAX,ISUB,NPAR(ISUB)
C
   40 IF (NUMMAT.LE.0) NUMMAT=1
C
      IF(MODEL.EQ.6) GO TO 45
      IF (MODEL.EQ.MODMAX) GO TO 45
C
      IDW=IDWAS(MODEL)
      NPAR(20)=IDW
      NCONT=NMCON(MODEL)
      IF (MODEL.EQ.8 .OR. MODEL.EQ.9) GO TO 42
      NCON=NCONT
      GO TO 50
C
   42 IF (NCON.NE.0) GO TO 43
      NCON=NCONT
      GO TO 50
   43 IF (NCON.GE.6 .AND. NCON.LE.16) GO TO 50
      ISTOP=ISTOP + 1
      ISUB=17
      NCNMN=6
      NCNMX=16
      WRITE (6,2250) ISUB,NCNMX,NCNMN
C
      GO TO 50
C
C     EMPTY MODEL - STOP IMMEDIATELY
C
   45 ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2450) MODEL
      WRITE (6,2700) ISTOP
      STOP
C
   50 IF (NORTHO.GE.0) GO TO 52
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=18
      IRANGE=0
      WRITE (6,2400) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
C
C     CHECK ON COMPATIBILITY BETWEEN ELEMENTS OF NPAR
C
C        1. COMPATIBILITY OF INDNL AND IDEATH
C
   52 ISUB=3
      IF (INDNL.GT.0) GO TO 55
      IF (IDEATH.EQ.0) GO TO 54
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=4
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C
C        2. COMPATIBILITY OF INDNL AND MODEL
C
C     INDNL = 0
C
   54 IF (MODEL.EQ.1) GO TO 60
      IF (MODEL.EQ.2) GO TO 60
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=15
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
      GO TO 60
C
C     INDNL = 1  AND  INDNL = 2  ALLOW ALL MODELS
C
   55 IF (INDNL.EQ.1 .OR. INDNL.EQ.2) GO TO 60
C
C     INDNL = 3 ALLOWS MODEL = 1 OR MODEL = 8 ONLY
C
      IF (MODEL.EQ.1 .OR. MODEL.EQ.8) GO TO 56
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=15
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
   56 IF (MODEL.EQ.8) IULJ=1
C
C        3. COMPATIBILITY OF NEGSKS AND NSKEWS
C
   60 IF (NEGSKS.EQ.0) GO TO 65
      IF (NSKEWS.GT.0) GO TO 65
      ISUB=6
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
C
C
C     CHECK FOR TEMPERATURE TAPE
C
   65 IF (MODEL.EQ.5) GO TO 66
C
      ITHER=0
      IF (MODEL.EQ. 3) ITHER=1
      IF (MODEL.EQ.10) ITHER=2
      IF (MODEL.EQ.11) ITHER=2
      ITHERM=ITHER
      GO TO 70
C
C     FOR CONCRETE MODEL, IITEMP MUST BE INPUT
C
   66 IF (ITHERM.EQ.0 .OR. ITHERM.EQ.2) GO TO 70
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=15
      ISUD=19
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
      WRITE (6,2580)
C
   70 ITEMPR=ITHERM
      IF (ITEMPR.EQ.0) GO TO 72
      IF (ITP96.GT.0) GO TO 72
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2600) ISTOP,ITP96,NPAR(15),NPAR(19)
C
C
   72 IF (ISTOP.EQ.0) GO TO 75
      WRITE (6,2700) ISTOP
      INPUT=5
      BACKSPACE INPUT
      READ (5,1000) DATA
      WRITE (6,2800) (I,I=1,8),DATA
      GO TO 80
C
   75 IF (IDATWR.GT.1) GO TO 90
C
C     PRINT OUT NPAR VECTOR
C
   80 WRITE (6,2900) NPAR1
      WRITE (6,2905) NUME,INDNL,IDEATH
      WRITE (6,2920) NEGSKS,MXNODS
      WRITE (6,2930) IDEGEN,NINT,NINTZ,NTABLE
      WRITE (6,2940) MODEL
      WRITE (6,2960) NUMMAT,NCON,NORTHO,IDW
C
   90 IF (ISTOP.EQ.0) GO TO 95
      IF (MODEX.EQ.0) GO TO 95
      WRITE (6,2750)
      STOP
C
C
C***  DATA PORTHOLE  *************************** (START)
C
   95 IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 100
      RECLAB=RECLB1
      WRITE (LU3) RECLAB,NG,(NPAR(I),I=1,20),NSUB
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   E N D   O F   C H E C K   O N   N P A R   V E C T O R           .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
  100 NDM=3*MXNODS
      NDM2=(NDM*NDM)/2 + NDM/2 + 1
      ND9DIM=MXNODS - 8
      IDW=NPAR(20)
      NDW=NDWS(MODEL)
      IDWA=IDW*(NINT*NINT*NINTZ)
C
C     STORAGE ALLOCATION
C
      NFIRST=N6
      IF (IND.EQ.4) NFIRST=N10
      N101=NFIRST + 20
      N102=N101 + NDM*NUME
      N103=N102 + NDM*NUME*ITWO
C
      N104=N103 + NUME
      N105=N104 + NUME
      N106=N105 + NUME
      N107=N106 + NUME*IDEGEN
      N108=N107 + NUME
      N109=N108 + ND9DIM*NUME
      N110=N109 + NUME
C
      N111=N110 + NUMMAT*ITWO
      N112=N111 + NCON*NUMMAT*ITWO
      N113=N112 + IDWA*NUME*ITWO
      IF (NPAR(19).GT.0) N113=N113 + NDW*MXNODS*NUME
      MM=0
      IF (IDEATH.GT.0) MM=1
      N114=N113 + MM*NUME*ITWO
      MM=0
      IF (IDEATH.EQ.1) MM=1
      N115=N114 + MM*NUME*NDM*ITWO
      N116=N115 + 16*NTABLE
      N117=N116 + 9*NORTHO*ITWO
      N118=N117 + NUME
      IF (NORTHO.EQ.0) N118=N117
      N119=N118
      IF (NEGSKS.GT.0) N119=N118 + NUME*MXNODS
      NLAST=N119
      IF (IULJ.GT.0) NLAST=N119 + NUME*NDM*ITWO
C
      N120=NLAST + 1
      N121=N120 + NDM2*ITWO
      N122=N121 + NDM*ITWO
      N123=N122 + NDM*ITWO
      N124=N123 + NDM*ITWO
      N125=N124 + NDM*ITWO
      N126=N125 + NDM*ITWO - 1
C
      NI=N126 - NLAST
      IF (NBCEL.LT.NI) NBCEL=NI
C
      IF (IND.NE.0) GO TO 105
C
      J=NFIRST-1
      DO 102 I=1,20
      J=J+1
  102 IA(J)=NPAR(I)
C
      MIDEST=(NLAST-NFIRST) + 1
      IF (IDATWR.LE.1) WRITE (6,2000) NG,MIDEST
      CALL SIZE (N126)
C
  105 IF (IND.GT.3) GO TO 110
      M2=N2
      M3=N3
      M4=N4
      GO TO 120
  110 M2=N2
      M3=N5
      M4=N8
      IF (ICOUNT.LT.3) GO TO 120
      M2=N6
      M3=N3
C
  120 CALL THDFE  (A(N06),A(N1A),
     1            A(N1),A(M2),A(M3),A(M4),A(N5),A(N101),A(N102),
     +            A(N103),A(N104),A(N105),A(N106),A(N107),A(N108),
     2            A(N109),A(N110),A(N111),A(N112),A(N120),A(N121),
     3            A(N122),A(N123),A(N124),A(N113),A(N114),A(N115),
     4            A(N116),A(N117),A(N118),A(N119),
     5            NTABLE,NCON,IDWA,NDM,NDM2,NDOF,ND9DIM,MXNODS)
C
C
      RETURN
C
C
 1000 FORMAT (20A4)
C
 2000 FORMAT (///38H S T O R A G E   I N F O R M A T I O N/
     1        //49H LENGTH OF ARRAY NEEDED FOR STORING ELEMENT GROUP/
     3        12H DATA (GROUP,I3,26H). . . . . . . . . . . . .,
     4       15H( MIDEST ). . =,I5//)
C
 2100 FORMAT (////28H *** I N P U T   E R R O R -//
     1 56H ERROR IN ELEMENT GROUP CONTROL CARDS  (3-DIM ELEMENT)  /
     2        16H ELEMENT GROUP =, I5/)
 2200 FORMAT (I5,7H. NPAR(,I2,27H) IS OUT OF RANGE ... NPAR(,I2,
     1        3H) =,I5)
 2250 FORMAT (6X,8H ( NPAR(,I2,15H) SHOULD BE LE.,I2,8H AND GE.,I2,2H ))
 2300 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .LE., I2,10H ... NPAR(,I2,
     1        3H) =,I5)
 2400 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .GE., I2,10H ... NPAR(,I2,
     1        3H) =,I5)
 2450 FORMAT (I5,48H. REQUESTED MATERIAL MODEL IS NOT AVAILABLE ... ,
     1        11H NPAR(15) =,I2)
 2500 FORMAT (I5,7H. NPAR(,I2,3H) =,I2,10H AND NPAR(,I2,3H) =,I2,
     1        19H ARE NOT COMPATIBLE )
 2550 FORMAT (I5,10H. NSKEWS =,I2,10H AND NPAR(,I2,3H) =,I2,
     1        19H ARE NOT COMPATIBLE )
 2580 FORMAT (5X,48H  FOR THE CONCRETE MODEL, NPAR(19) MUST BE EQ.0,,
     1        10H OR EQ.2 .)
 2600 FORMAT (I5,9H. ITP96 =,I2/
     1        5X,47H  FOR THE MATERIAL MODEL REQUESTED BY NPAR(15)=,I2/
     2        5X,15H  AND NPAR(19)=,I2,24H, TEMPERATURES SHOULD BE,
     3        36H PROVIDED (I.E. ITP96 MUST BE GT.0).)
 2700 FORMAT (//25H TOTAL NUMBER OF ERRORS =,I5//
     1        48H CARD IMAGE LISTING AND PRINT-OUT OF NPAR VECTOR/
     2        48H (WITH DEFAULTS ENFORCED) ARE GIVEN BELOW ------)
 2800 FORMAT (///34H CARD IMAGE LISTING OF NPAR VECTOR //29X,8(I1,9X)/
     1        15H COLUMN NUMBERS,5X,8(10H1234567890)/
     2        15H NPAR VECTOR   ,5X,20A4 // )
 2750 FORMAT (//// 23H STOP  (ERRORS IN NPAR)  )
C
 2900 FORMAT (36H E L E M E N T   D E F I N I T I O N ///,
     1        14H ELEMENT TYPE ,13(2H .),16H( NPAR(1) ). . =,I5/,
     2        25H     EQ.1, TRUSS ELEMENTS/,
     3        25H     EQ.2, 2-DIM ELEMENTS/,
     4        25H     EQ.3, 3-DIM ELEMENTS/,
     5        25H     EQ.4, BEAM  ELEMENTS/,
     5        28H     EQ.5, ISO/BEAM ELEMENTS/,
     6        28H     EQ.6, PLATE ELEMENTS   /,
     C        25H     EQ.7, SHELL ELEMENTS/,
     D        25H     EQ.8,9,10, EMPTY    /,
     G        32H     EQ.11, 2-DIM FLUID ELEMENTS/,
     5        32H     EQ.12, 3-DIM FLUID ELEMENTS   /)
 2905 FORMAT (20H NUMBER OF ELEMENTS.,10(2H .),16H( NPAR(2) ). . =,I5//,
     5        40H TYPE OF NONLINEAR ANALYSIS  . . . . . .      ,
     6        16H( NPAR(3) ). . =,I5/,
     +        40H     EQ.0, LINEAR                          /,
     7        40H     EQ.1, MATERIAL NONLINEARITY ONLY      /,
     8        40H     EQ.2, TOTAL LAGRANGIAN FORMULATION    /,
     9        44H     EQ.3, UPDATED LAGRANGIAN FORMULATION           //
     +        32H ELEMENT BIRTH AND DEATH OPTIONS ,4(2H .),
     +        16H( NPAR(4) ). . =,I5/,
     +        28H     EQ.0, OPTION NOT ACTIVE/,
     +        30H     EQ.1, BIRTH OPTION ACTIVE /,
     A        30H     EQ.2, DEATH OPTION ACTIVE )
 2920 FORMAT(/23H SKEW COORDINATE SYSTEM/
     B        40H     REFERENCE INDICATOR . . . . . . . .,
     C        16H( NPAR(6) ). . =,I5/
     D        28H     EQ.0, ALL ELEMENT NODES/
     E        37H           USE THE GLOBAL SYSTEM ONLY/
     F        35H     EQ.1, ELEMENT NODES REFER     /
     G        36H           TO SKEW COORDINATE SYSTEM//
     A        32H MAX NUMBER OF NODES DESCRIBING  /,
     1        20H     ANY ONE ELEMENT,10(2H .),16H( NPAR(7) ). . =,I5//)
 2930 FORMAT (24H DEGENERATION INDICATOR ,8(2H .),
     A        16H( NPAR(8) ). . =,I5/,
     B        44H     EQ.0, NO DEGENERATION OR NO CORRECTION         /,
     C        44H           FOR SPATIAL ISOTROPY                     /,
     D        44H     EQ.1, SPATIAL ISOTROPY CORRECTIONS             /,
     E        44H           APPLIED TO SPECIALLY                     /,
     F        44H           DEGENERATED 20-NODE ELEMENTS             //,
     1        40H INTEGRATION ORDER (R-S DIRECTION) FOR  /,
     2        40H     ELEMENT STIFFNESS GENERATION. . . .,
     3        16H( NPAR(10)). . =,I5//,
     4        40H INTEGRATION ORDER (T DIRECTION) FOR    /,
     5        40H     ELEMENT STIFFNESS GENERATION. . . .,
     6        16H( NPAR(11)). . =,I5//,
     7        40H NUMBER OF STRESS OUTPUT TABLES  . . . .,
     8        16H( NPAR(13)). . =,I5/
     9        38H     EQ.0, PRINT AT INTEGRATION POINTS            ///)
 2940 FORMAT (38H M A T E R I A L   D E F I N I T I O N///,
     1        16H MATERIAL MODEL.,12(2H .),16H( NPAR(15)). . =,I5/,
     2        36H     EQ. 1, LINEAR ELASTIC ISOTROPIC/
     3        38H     EQ. 2, LINEAR ELASTIC ORTHOTROPIC/
     4        31H     EQ. 3, THERMOELASTIC MODEL/
     4        45H     EQ. 4, NONLINEAR CURVE DESCRIPTION MODEL/
     5        35H     EQ. 5, CONCRETE CRACKING MODEL/
     6        19H     EQ. 6, (EMPTY)/
     7        50H     EQ. 7, DRUCKER PRAGER (CAP) MODEL               /,
     8        52H     EQ. 8, ELASTIC-PLASTIC WITH ISOTROPIC HARDENING/
     9        52H     EQ. 9, ELASTIC-PLASTIC WITH KINEMATIC HARDENING/
     A        51H     EQ.10, ELASTIC-PLASTIC WITH CREEP (ISOTROPIC) /,
     B        51H     EQ.11, ELASTIC-PLASTIC WITH CREEP (KINEMATIC) /,
     C        35H     EQ.12, (EMPTY)                        /)
 2960 FORMAT (37H NUMBER OF DIFFERENT SETS OF MATERIAL /,
     6        14H     CONSTANTS,13(2H .),16H( NPAR(16)). . =,I5//,
     7        40H NUMBER OF MATERIAL CONSTANTS PER SET. .,
     8        16H( NPAR(17)). . =,I5//,
     +        32H NUMBER OF AXIS ORIENTATION SETS  ,4(2H .),
     +        16H( NPAR(18)). . = ,I5//,
     9        32H DIMENSION OF STORAGE ARRAY (WA)/,
     1        26H     PER INTEGRATION POINT,7(2H .),16H( NPAR(20)). . =,
     2        I5//)
C
      END
C *CDC* *DECK THDFE
C *UNI* )FOR,IS  N.THDFE,  R.THDFE
      SUBROUTINE THDFE (RSDCOS,NODSYS,ID,X,Y,Z,HT,LM,XYZ,IELTD,IELTX,
     1                  IPST,ISO,MATP,NOD9,IREUSE,DEN,PROP,WA,S,XM,B,RE,
     2                  EDIS,ETIMV,EDISB,ITABLE,DCA,MAXESV,ISKEW,PDIS,
     3                  NTABLE,NCON,IDWA,NDM,NDM2,NDOF,ND9DIM,MXNODS)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON/ELSTP/TIME,IDTHF
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,N,IPS
      COMMON /DISDR/ DISD(9)
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
      COMMON /MDFRDM/ IDOF(6)
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /SKEW  / NSKEWS
      COMMON /ULJ/ IULJ
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      COMMON A(1)
      REAL A
C
      DIMENSION ID(NDOF,1),X(1),Y(1),Z(1),HT(1),LM(NDM,1),XYZ(NDM,1),
     1          IELTD(1),IELTX(1),IPST(1),ISO(1),MATP(1),DEN(1),
     2          PROP(NCON,1),WA(IDWA,1),S(1),XM(1),B(1),RE(1),
     3          EDIS(1),ETIMV(1),DCA(3,3,1),MAXESV(1),PDIS(NDM,1),
     4          NOD9(ND9DIM,1),IREUSE(1),ITABLE(NTABLE,1),EDISB(NDM,1)
      DIMENSION RSDCOS(9,1),NODSYS(1),ISKEW(MXNODS,1)
C
      DIMENSION XXX(63),V2(3),IPTABL(8),H(21),P(3,21),XJ(3,3),
     1          XYZINT(3,64),EDISI(63)
      INTEGER ANODE
      EQUIVALENCE (NPAR(2),NUME),(NPAR(16),NUMMAT),(NPAR(15),MODEL)
     1           ,(NPAR(10),NINT),(NPAR(11),NINTZ),(NPAR(6),NEGSKS)
     2           ,(NPAR(3),INDNL),(NPAR(4),IDEATH),(NPAR(18),NORTHO)
     3           ,(NPAR(8),IDEGEN)
C
      DATA ANODE /4HNODE/, RECLB1/8HTYPE-3  /, RECLB2/8HMATERAL3/,
     1     RECLB3/8HOUTABLE3/, RECLB4/8HELEMENT3/,
     2     RECLB5/8HNEWSTEP3/, RECLB6/8HOUTPUT-3/, RECLB7/8HIPOINT-3/
C
C
C
C     .. NOTE .. DURING TIME INTEGRATION X=DISPLACEMENT
C                                        Y=DISPLACEMENT INCREMENTS
C                                        Z=ACCELERATION
C
C
      IELCPL=0
      IF (JNPORT.EQ.0) GO TO 3
      IPTABL(1)=1
      IPTABL(2)=NINTZ
      IPTABL(3)=NINTZ*(NINT-1) + 1
      IPTABL(4)=NINT*NINTZ
      IPTABL(5)=NINT*NINTZ*(NINT-1) + 1
      IPTABL(6)=IPTABL(5) + NINTZ - 1
      IPTABL(7)=IPTABL(5) + NINTZ*(NINT-1)
      IPTABL(8)=IPTABL(7) + NINTZ - 1
C
    3 IF (KPRI.EQ.0) GO TO 800
      IF (IND.GT.0) GO TO 420
C
      ISCONT=0
      IF (NSKEWS.GT.0 .AND. NEGSKS.EQ.0) ISCONT=1
      IJPORT=1
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) IJPORT=0
C
C
C
C     R E A D   A N D   G E N E R A T E   E L E M E N T
C     I N F O R M A T I O N
C
C
      NPT=NINT*NINT*NINTZ
      IDW=IDWA/NPT
      IEPMOD=0
      NEPCON=0
      IF (MODEL.NE.8 .AND. MODEL.NE.9) GO TO 5
      IEPMOD=1
      NEPCON=(NCON-1)/4
    5 DO 10 I=1,NUMMAT
      READ(5,1000) N,DEN(N)
      READ(5,1001) (PROP(J,N), J=1,NCON)
      IF (IEPMOD.EQ.1 .AND. NEPCON.EQ.1) READ (5,1001)
   10 CALL MATWRT (N,DEN(N),PROP(1,N))
C
C     MATERIAL AXIS ORIENTATION SETS FOR MODEL 2
C
      IF (NORTHO.EQ.0) GO TO 20
C
      IF (IDATWR.LE.1) WRITE (6,2055)
      DO 15 M=1,NORTHO
      READ (5,1004) N,NI,NJ,NK
      IF (IDATWR.LE.1) WRITE (6,2057) N,NI,NJ,NK
C
C     GENERATE DIRECTION COSINE ARRAY FOR THIS DATA SET
C
      CALL VECTR2 (DCA(1,1,M),X(NI),Y(NI),Z(NI),X(NJ),Y(NJ),Z(NJ),IERR)
      IF (IERR.EQ.0) GO TO 12
      WRITE (6,3000)
      STOP
   12 CALL VECTR2 (V2,X(NI),Y(NI),Z(NI),X(NK),Y(NK),Z(NK),IERR)
      IF (IERR.EQ.0) GO TO 13
      WRITE (6,3010)
      STOP
   13 CALL CROSS2 (DCA(1,1,M),V2,DCA(1,3,M),IERR)
      IF (IERR.EQ.0) GO TO 14
      WRITE (6,3020)
      STOP
   14 CALL CROSS2 (DCA(1,3,M),DCA(1,1,M),DCA(1,2,M),IERR)
      IF (IERR.EQ.0) GO TO 15
      WRITE (6,3030)
      STOP
   15 CONTINUE
C
C     READ TABLES FOR ELEMENT STRESS OUTPUT LOCATIONS
C
   20 IF (NTABLE.EQ.0) GO TO 90
      IF (IDATWR.LE.1) WRITE (6,2070)
      DO 25 L=1,NTABLE
      READ(5,1007) (ITABLE(L,I),I=1,16)
   25 IF (IDATWR.LE.1) WRITE (6,2060) L,(ITABLE(L,I),I=1,16)
C
C     READ ELEMENT INFORMATION
C
  90  IELN=8
      IF (MXNODS.GT.8) IELN=21
      IF (IDATWR.GT.1) GO TO 95
      WRITE (6,2005) (ANODE,I,I=1,IELN)
      WRITE (6,2006)
   95 CONTINUE
      N=1
      IREAD=5
      IF (INPORT.GT.0) IREAD=59
C
C***  DATA PORTHOLE (START)
C
      IF (IJPORT.EQ.0) GO TO 100
      RECLAB=RECLB2
      WRITE (LU3)  RECLAB,NUMMAT,NCON,(DEN(I),I=1,NUMMAT),
     1             ((PROP(I,J),I=1,NCON),J=1,NUMMAT)
      RECLAB=RECLB3
      IF(NTABLE.EQ.0)
     1 WRITE (LU3)  RECLAB,NTABLE
      IF(NTABLE.GT.0)
     1 WRITE (LU3) RECLAB,NTABLE,((ITABLE(I,J),I=1,NTABLE),J=1,16)
C
C***  DATA PORTHOLE (END)
C
  100 READ (IREAD,1004) M,IELD,IELX,IPS,MTYP,MAXES,IST,KG,ETIME,INTLOC
      IF (N.EQ.1 .AND. M.NE.1) GO TO 101
      IF (IDEATH.EQ.2 .AND. ETIME.EQ.0.) ETIME=100000.
      IF (IELD.EQ.0) IELD=MXNODS
      IF (IELX.EQ.0) IELX=IELD
      IEL=IELD
      IF (IELX.GT.IELD) IELX=IELD
      READ(IREAD,1005) (NOD(I),I=1,8)
      READ(IREAD,1005) (NOD(I),I=9,21)
      IF (NDM.GE.IEL*3) GO TO 105
      WRITE(6,2010) M
      STOP
  101 WRITE (6,2015) NSUB,NG
      STOP
  105 IF (KG.EQ.0) KG=1
C
  120 IF (M.NE.N) GO TO 200
  121 DO 110 I=1,IELN
  110 NODM(I)=NOD(I)
      IF (IEL.EQ.8) GO TO 115
      II=0
      DO 114 I=9,21
      NN=NOD(I)
      IF (NN.EQ.0) GO TO 114
      II=II + 1
      NOD9M(II)=I
  114 CONTINUE
      NN=II + 8
      IF (NN.EQ.IEL) GO TO 115
      WRITE(6,2090) N
      STOP
  115 IELM=IEL
      IELDM=IELD
      IELXM=IELX
      IPSM=IPS
      MTYPE=MTYP
      KAXES=MAXES
      ISTM=IST
      KKK=KG
      ETIM=ETIME
      INTLM=INTLOC
C
C     SAVE ELEMENT INFORMATION
C
  200 I2=0
      DO 130 I=1,IELM
      II=NODM(I)
      IF (I.LE.8) GO TO 131
      JJ=NOD9M(I-8)
      II=NODM(JJ)
  131 I2=I2 + 3
      XYZ(I2-2,N)=X(II)
      XYZ(I2-1,N)=Y(II)
      XYZ(I2,N)=Z(II)
      IF (ISCONT.EQ.0) GO TO 129
      IF (NODSYS(II).EQ.0) GO TO 130
      WRITE (6,2410) NG,N,NEGSKS
      STOP
  129 IF (NEGSKS.GT.0) ISKEW(I,N)=NODSYS(II)
  130 CONTINUE
C
      IF (IULJ.EQ.0) GO TO 128
      DO 127 I=1,NDM
  127 PDIS(I,N)=0.
  128 CONTINUE
C
      IF (NEGSKS.EQ.0) GO TO 134
      DO 133 I=1,IELM
      IF (ISKEW(I,N).NE.0) GO TO 134
  133 CONTINUE
      ISKEW(1,N)=-1
C
  134 IF (IDEGEN.LE.0) GO TO 136
      ISOCOR=1
      IF (IELM.NE.20 .OR. NODM(17).NE.NODM(20)) GO TO 138
      IF (NODM(1).NE.NODM(4) .OR. NODM(1).NE.NODM(12)) GO TO 138
      IF (NODM(5).NE.NODM(8) .OR. NODM(5).NE.NODM(16)) GO TO 138
      IF (NODM(1).EQ.NODM(5) .OR. NODM(2).EQ.NODM(6) .OR.
     1    NODM(3).EQ.NODM(7)) GO TO 138
      IF (NODM(5).EQ.NODM(6) .OR. NODM(6).EQ.NODM(7) .OR.
     1    NODM(5).EQ.NODM(7)) GO TO 138
      ICOLPS=0
      IF (NODM(3).EQ.NODM(2) .AND. NODM(10).EQ.NODM(2)) ICOLPS=ICOLPS+1
      IF (NODM(2).EQ.NODM(1) .AND. NODM(9).EQ.NODM(1))  ICOLPS=ICOLPS+1
      IF (NODM(3).EQ.NODM(1) .AND. NODM(11).EQ.NODM(1)) ICOLPS=ICOLPS+1
      IF (ICOLPS.EQ.0) ISOCOR=2
      IF (ICOLPS.EQ.3) ISOCOR=3
      IF (ISOCOR.GT.1 .AND. IELXM.NE.IELDM) IELXM=8
  138 ISO(N)=ISOCOR
  136 MATP(N)=MTYPE
      IF (NORTHO.EQ.0) GO TO 145
      MAXESV(N)=KAXES
  145 IELTD(N)=IELDM
      IELTX(N)=IELXM
      IPST(N)=IPSM
      IREUSE(N)=ISTM
      IF (IELM.EQ.8) GO TO 135
      NN=IELM - 8
      DO 132 I=1,NN
  132 NOD9(I,N)=NOD9M(I)
  135 KK=-3
      DO 140 I=1,IELM
      II=NODM(I)
      IF (I.LE.8) GO TO 137
      JJ=NOD9M(I-8)
      II=NODM(JJ)
  137 KK=KK + 3
      LL=1
      DO 140 L=1,3
      LM(KK+L,N)=0
      IF (IDOF(L).EQ.1) GO TO 140
      LM(KK+L,N)=ID(LL,II)
      LL=LL+1
  140 CONTINUE
      IF (IDEATH.EQ.0) GO TO 150
      IF (IDEATH.EQ.2) GO TO 156
      DO 158 L=1,NDM
  158 EDISB(L,N)=0.
      ETIMV(N)=-ETIM
      GO TO 150
  156 ETIMV(N)=ETIM
C
C     UPDATE COLUMN HEIGHTS AND BANDWIDTH
C
  150 ND=IELM*3
      CALL COLHT(HT,ND,LM(1,N))
C
C     INITIALIZE STORAGE AND PRINT ELEMENT INFORMATION
C
      IELTP=IEL
      IEL=IELM
      IELD=IELDM
      NND9=IELM - 8
      CALL INTWA3 (MODEL)
      IEL=IELTP
      IELD=IELTP
      IF (IDATWR.LE.1)
     1WRITE (6,2004) N,IELDM,IELXM,IPSM,MTYPE,KAXES,ISTM,KKK,ETIM,INTLM,
     +            (NODM(I),I=1,IELN)
      IF (IJPORT.EQ.0 .AND. INTLM.EQ.0) GO TO 159
C
C     CALCULATE GLOBAL COORDINATES OF INTEGRATION POINTS
C
      KINTP=0
      ND=3*IELDM
      DO 164 LX=1,NINT
      RINTP=XG(LX,NINT)
      DO 164 LY=1,NINT
      SINTP=XG(LY,NINT)
      DO 164 LZ=1,NINTZ
      TINTP=XG(LZ,NINTZ)
      KINTP=KINTP+1
      XINT=0.
      YINT=0.
      ZINT=0.
      IX=0
C
      CALL FUNCT (RINTP,SINTP,TINTP,H,P,NOD9M,XJ,DET,XYZ(1,N),1)
C
      DO 165 NDPT=1,IELXM
      IX=IX+3
      XINT=XINT + H(NDPT)*XYZ(IX-2,N)
      YINT=YINT + H(NDPT)*XYZ(IX-1,N)
  165 ZINT=ZINT + H(NDPT)*XYZ(IX,N)
C
      XYZINT(1,KINTP)=XINT
      XYZINT(2,KINTP)=YINT
      XYZINT(3,KINTP)=ZINT
C
C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
C
      IF (IDATWR.GT.1 .OR. INTLM.LE.0) GO TO 164
      WRITE (6,2008) KINTP,(XYZINT(L,KINTP),L=1,3)
  164 CONTINUE
C
C***  DATA PORTHOLE (START)
C
      RECLAB=RECLB4
      IF (IJPORT.EQ.0) GO TO 159
      WRITE (LU3) RECLAB,N,IELDM,IELXM,IPSM,MTYPE,KAXES,ISTM,ETIM,
     1            INTLM,IELN,(NODM(I),I=1,IELN)
      RECLAB = RECLB7
      WRITE (LU3) RECLAB,NPT,((XYZINT(L,I),L=1,3),I=1,NPT)
C
C***  DATA PORTHOLE (END)
C
C
  159 CONTINUE
      IF (N.EQ.NUME) GO TO 170
      N=N+1
      DO 160 I=1,IELN
      IF (NODM(I).EQ.0) GO TO 160
      NODM(I)=NODM(I) + KKK
  160 CONTINUE
      IF (N-M) 200,121,100
C
  170 IF (NEGSKS.EQ.0) RETURN
      DO 175 N=1,NUME
      IF (ISKEW(1,N).GE.0) GO TO 180
  175 CONTINUE
      WRITE (6,2400) NG,NEGSKS
C
  180 RETURN
C
C
  420 GO TO (440,560,560,700), IND
C
C
C     A S S E M B L E  L I N E A R  S T I F F N E S S  M A T R I X
C
C
  440 DO 445 I=1,NDM
      RE(I)=0.0
  445 EDIS(I)=0.0
      NPT=NINT*NINT*NINTZ
      DO 500 N=1,NUME
      MTYPE=MATP(N)
      ISOCOR=ISO(N)
      MAXES=0
      IF (NORTHO.EQ.0) GO TO 460
      MAXES=MAXESV(N)
  460 IELD=IELTD(N)
      IELX=IELTX(N)
      IEL=IELD
      IST=IREUSE(N)
      ND=3*IELD
      NND9=IELD - 8
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 500
      IF (NBLOCK.EQ.1 .AND. IST.NE.0) GO TO 525
      DO 480 I=1,NDM2
  480 S(I)=0.0
C
      CALL QUADS3 (ND,B,S,XYZ(1,N),PROP(1,MTYPE),DCA(1,1,MAXES),RE,EDIS,
     1             EDISI,WA(1,N),NOD9(1,N),MAXES)
      IF (NEGSKS.EQ.0) GO TO 525
      IF (ISKEW(1,N).LT.0) GO TO 525
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
C
  525 CONTINUE
      CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  500 CONTINUE
C
      RETURN
C
C     A S S E M B L E  M A S S  M A T R I C E S
C
C
  560 DO 640 N=1,NUME
      MTYPE=MATP(N)
      IELD=IELTD(N)
      IELX=IELTX(N)
      ISOCOR=ISO(N)
      IEL=IELD
      IST=IREUSE(N)
      ND=3*IELD
      NND9=IELD - 8
      DE=DEN(MTYPE)
      IF (IMASS.EQ.1) GO TO 520
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 640
  520 IF (NBLOCK.EQ.1 .AND. IST.NE.0) GO TO 550
C
      CALL QUADM3  (N,ND,NDM2,XM,S,XYZ(1,N),NOD9(1,N))
C
  550 IF (IMASS.EQ.2) GO TO 580
      CALL ADDMA (A(N4),XM,LM(1,N),ND)
      GO TO 640
  580 IF (NEGSKS.EQ.0) GO TO 590
      IF (ISKEW(1,N).LT.0) GO TO 590
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
  590 CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  640 CONTINUE
C
      RETURN
C
C
C     A S S E M B L E   N O N L I N E A R   F I N A L   S T R U C T U R
C     S T I F F N E S S   A N D   E F F E C T I V E   L O A D S
C
C
  700 MADR=N3
      IF (ICOUNT.EQ.3) MADR=N5
      ISTIF=0
      IF (ICOUNT.NE.3 .AND. IREF.EQ.0) ISTIF=1
C
      DO 710 N=1,NUME
      MTYPE=MATP(N)
      MAXES=0
      IF (NORTHO.EQ.0) GO TO 725
      MAXES=MAXESV(N)
  725 IELD=IELTD(N)
      IELX=IELTX(N)
      ISOCOR=ISO(N)
      IEL=IELD
      ND=3*IELD
      NND9=IELD - 8
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE .EQ. 1) IELCPL=IELCPL + 1
      IF (ICODE.EQ.1) GO TO 710
      IF (IDEATH.EQ.0) GO TO 720
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 712
      IF (TIME.LT.ETIM) GO TO 710
      IF (ETIMV(N).GE.0.) GO TO 720
      ETIMV(N)=ETIM
      DO 714 I=1,ND
      II=LM(I,N)
      IF (II.EQ.0) GO TO 714
      IF(II.LT.0) II=NEQ - II
      EDISB(I,N)=X(II)
  714 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 720
      IF (ISKEW(1,N).LT.0) GO TO 720
      CALL DIRCOS (RSDCOS,EDISB(1,N),ISKEW(1,N),IELD,3,1)
      GO TO 720
  712 IF (TIME.GT.ETIM) GO TO 710
  720 DO 740 I=1,ND
      RE(I)=0.0
      EDIS(I)=0.0
      EDISI(I)=0.0
      XXX(I)=XYZ(I,N)
      II=LM(I,N)
      IF (II) 736,740,737
  736 II=NEQ - II
  737 EDIS(I)=X(II)
  740 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 742
      IF (ISKEW(1,N).LT.0) GO TO 742
      CALL DIRCOS (RSDCOS,EDIS,ISKEW(1,N),IELD,3,1)
C
  742 DO 750 I=1,NDM2
  750 S(I)=0.0
C
      IF (IDEATH.NE.1) GO TO 752
      DO 754 I=1,ND
      EDIS(I)=EDIS(I) - EDISB(I,N)
  754 XXX(I)=XXX(I) + EDISB(I,N)
C
  752 IF (IULJ.EQ.0) GO TO 756
      DO 743 I=1,ND
      EDISI(I)=EDIS(I) - PDIS(I,N)
      IF (ICOUNT.LE.2 .AND. IUPDT.EQ.0) PDIS(I,N)=EDIS(I)
  743 CONTINUE
C
  756 CALL QUADS3 (ND,B,S,XXX,PROP(1,MTYPE),DCA(1,1,MAXES),RE,EDIS,
     1             EDISI,WA(1,N),NOD9(1,N),MAXES)
C
      IF  (NEGSKS.EQ.0) GO TO 760
      IF (ISKEW(1,N).LT.0) GO TO 760
      CALL DIRCOS (RSDCOS,RE,ISKEW(1,N),IELD,3,2)
  760 CALL ADDBAN (A(MADR),A(N1),S,RE,LM(1,N),ND,2)
C
      IF (ISTIF.EQ.0) GO TO 710
      IF (NEGSKS.EQ.0) GO TO 730
      IF (ISKEW(1,N).LT.0) GO TO 730
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
  730 CALL ADDBAN (A(N4),A(N1),S,RE,LM(1,N),ND,1)
C
  710 CONTINUE
C
      IF (IELCPL.EQ.NUME) IELCPL=-1
      RETURN
C
C
C     S T R E S S  C A L C U L A T I O N S
C
C
C
C***  DATA PORTHOLE (START)
C
  800 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 811
      RECLAB=RECLB5
      WRITE (LU3)  RECLAB,NG,(NPAR(I),I=1,20),KSTEP,TIME,NEGL,NSUB
C
C***  DATA PORTHOLE (END)
C
  811 IPRNT=0
      DO 840 N=1,NUME
      IF (IDEATH.EQ.0) GO TO 790
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 792
      IF (TIME.LT.ETIM) GO TO 840
      GO TO 790
  792 IF (TIME.GT.ETIM) GO TO 840
  790 IPS=IPST(N)
      IF (IPS.EQ.0) GO TO 840
      IF (IPRI.NE.0) GO TO 802
      IPRNT=IPRNT + 1
      IF (IPRNT.NE.1) GO TO 802
      WRITE(6,2020) NG
      IF (MODEL.GT.2) GO TO 802
      WRITE(6,2030)
  802 MTYPE=MATP(N)
      MAXES=0
      IF (NORTHO.EQ.0) GO TO 803
      MAXES=MAXESV(N)
  803 IELD=IELTD(N)
      IELX=IELTX(N)
      ISOCOR=ISO(N)
      IEL=IELD
      ND=3*IEL
      NND9=IELD - 8
C
      DO 805 I=1,ND
      EDIS(I)=0.
      EDISI(I)=0.0
      II=LM(I,N)
      IF (II.EQ.0) GO TO 805
      IF (II.LT.0) II=NEQ - II
      EDIS(I)=X(II)
  805 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 845
      IF (ISKEW(1,N).LT.0) GO TO 845
      CALL DIRCOS (RSDCOS,EDIS,ISKEW(1,N),IELD,3,1)
C
  845 DO 806 I=1,ND
  806 XXX(I)=XYZ(I,N)
C
      IF (IDEATH.NE.1) GO TO 807
      DO 804 I=1,ND
      EDIS(I)=EDIS(I) - EDISB(I,N)
  804 XXX(I)=XXX(I) + EDISB(I,N)
C
  807 IF (INDNL.LT.3) GO TO 809
      DO 808 I=1,ND
  808 XXX(I)=XXX(I)+EDIS(I)
C
  809 IF (IULJ.EQ.0) GO TO 848
      DO 846 I=1,ND
  846 EDISI(I)=EDIS(I) - PDIS(I,N)
C
C     FORM LINEAR STRESS-STRAIN LAW IF APPLICABLE
C
  848 IF (MODEL.GT.2) GO TO 831
      CALL STST3L (N,XXX,PROP(1,MTYPE),DCA(1,1,MAXES),D,MAXES)
C
      IF (IPRI.EQ.0) WRITE (6,2035) N
C
C     CALCULATE AND PRINT ELEMENT STRESSES AT IPS LOCATIONS
C
      IF (NTABLE.EQ.0) GO TO 831
      DO 830 II=1,16
      M=ITABLE(IPS,II)
      IF (M.EQ.0) GO TO 840
      CALL DERIQ3 (N,XXX,B,DET,EVAL3(M,1),EVAL3(M,2),EVAL3(M,3),
     1              NOD9(1,N))
C
      DO 810 J=1,9
  810 DISD(J)=0.0
      DO 815 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1)+B(K)*EDIS(K)
      DISD(2)=DISD(2)+B(I)*EDIS(I)
      DISD(3)=DISD(3)+B(J)*EDIS(J)
      DISD(4)=DISD(4)+B(I)*EDIS(K)
      DISD(5)=DISD(5)+B(J)*EDIS(K)
      DISD(6)=DISD(6)+B(K)*EDIS(I)
      DISD(7)=DISD(7)+B(J)*EDIS(I)
      DISD(8)=DISD(8)+B(K)*EDIS(J)
  815 DISD(9)=DISD(9)+B(I)*EDIS(J)
C
      CALL STST3N (DISD)
C
C
C     TRANSFORM PIOLA-KIRCHHOFF STRESSES TO CAUCHY STRESSES
C
C        CS = (1./DET(F)) * ( F * PK * F(TRANSPOSED) )
C
      IF (INDNL.NE.2) GO TO 822
C
      CALL CAUCH3
C
C
C***  DATA PORTHOLE (START)
C
  822 RECLAB=RECLB6
      IF (JNPORT.NE.0 .AND. KPLOTE.EQ.0)
     1 WRITE (LU3) RECLAB,M,STRESS,STRAIN
C
C***  DATA PORTHOLE (END)
C
  830 IF (IPRI.EQ.0) WRITE (6,2040) M,STRESS
      GO TO 840
C
C     CALCULATE AND PRINT STRESSES AT INTEGRATION POINTS
C
  831 IPT=0
      JPT=1
      RECLAB=RECLB6
      DO 939 LX=1,NINT
      E1=XG(LX,NINT)
      DO 939 LY=1,NINT
      E2=XG(LY,NINT)
      DO 939 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      IPT=IPT+1
C
      CALL DERIQ3 (N,XXX,B,DET,E1,E2,E3,NOD9(1,N))
C
      DO 910 J=1,9
  910 DISD(J)=0.0
C
C     FOR U.L.J. FORMULATION USE STRAIN INCREMENTS
C
      IF (INDNL.EQ.3 .AND. MODEL.GT.1) GO TO 919
      DO 915 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1)+B(K)*EDIS(K)
      DISD(2)=DISD(2)+B(I)*EDIS(I)
      DISD(3)=DISD(3)+B(J)*EDIS(J)
      DISD(4)=DISD(4)+B(I)*EDIS(K)
      DISD(5)=DISD(5)+B(J)*EDIS(K)
      DISD(6)=DISD(6)+B(K)*EDIS(I)
      DISD(7)=DISD(7)+B(J)*EDIS(I)
      DISD(8)=DISD(8)+B(K)*EDIS(J)
  915 DISD(9)=DISD(9)+B(I)*EDIS(J)
      GO TO 925
C
  919 DO 920 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1) + B(K)*EDISI(K)
      DISD(2)=DISD(2) + B(I)*EDISI(I)
      DISD(3)=DISD(3) + B(J)*EDISI(J)
      DISD(4)=DISD(4) + B(I)*EDISI(K)
      DISD(5)=DISD(5) + B(J)*EDISI(K)
      DISD(6)=DISD(6) + B(K)*EDISI(I)
      DISD(7)=DISD(7) + B(J)*EDISI(I)
      DISD(8)=DISD(8) + B(K)*EDISI(J)
  920 DISD(9)=DISD(9) + B(I)*EDISI(J)
C
  925 IF (IULJ.GT.0 .AND. IPRI.EQ.0)  CALL CGDT3 (XYZ(1,N),EDIS,ND,
     1    NOD9(1,N),E1,E2,E3,IDEATH,EDISB(1,N))
      CALL STST3N (DISD)
C
C
C     TRANSFORM PIOLA-KIRCHHOFF STRESSES TO CAUCHY STRESSES
C
C        CS = (1./DET(F)) * ( F * PK * F(TRANSPOSED) )
C
      IF (MODEL.GT.2) GO TO 938
      IF (INDNL.NE.2) GO TO 930
C
      CALL CAUCH3
C
  930 IF (IPRI.EQ.0) WRITE (6,2040) IPT,STRESS
C
C***  DATA PORTHOLE (START)
C
  938 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 939
      IF (IPT.NE.IPTABL(JPT)) GO TO 939
      WRITE (LU3) RECLAB,IPT,STRESS,STRAIN
      JPT=JPT + 1
C
C***  DATA PORTHOLE (END)
C
  939 CONTINUE
  840 CONTINUE
      RETURN
C
C
 1000 FORMAT (I5,F10.0)
 1001 FORMAT (8F10.0)
 1004 FORMAT (8I5,F10.0,I5)
 1005 FORMAT (13I5)
 1007 FORMAT (16I5)
 2004 FORMAT (/I6,1X,4(I3,2X),I4,2X,I2,3X,I2,1X,E11.4,
     1        1X,I4,3X,8(4X,I4)/64X,I4,7(4X,I4)/64X,I4,7(4X,I4))
 2005 FORMAT (///40H E L E M E N T   I N F O R M A T I O N      ,
     1        ///6H     M,5H IELD,5H IELX,5H IPS ,5H MTYP,6H MAXES,
     2        5H IST ,4H KG ,11H   ETIME   ,6HINTLOC,5X,8(A4,I1,3X)/
     3        63X,A4,I1,3X,7(A4,I2,2X)/63X,8(A4,I2,2X)/)
 2006 FORMAT (56X,11HINTEGRATION,17X,19HGLOBAL  COORDINATES/
     5        59X,5HPOINT,16X,1HX,12X,1HY,12X,1HZ)
 2008 FORMAT (1H ,57X,I4,12X,2(E11.4,2X),E11.4)
 2010 FORMAT(///12H *** ELEMENT,I5,46H+EXCEEDS MAXIMUM NUMBER OF NODES (
     1NPAR(4)) ***)
 2015 FORMAT(///23H INPUT ERROR **********/
     1          19H SUBSTRUCTURE  NO =,I3/
     2          19H ELEMENT GROUP NO =,I3/
     3          31H FIRST ELEMENT NUMBER MUST BE 1)
 2020 FORMAT (1H1,45HS T R E S S   C A L C U L A T I O N S   F O R, 3X,
     1        25HE L E M E N T   G R O U P,3X,I2,3X,15H(3/D CONTINUUM)
     2        /)
 2030 FORMAT (8H ELEMENT,4X,6HOUTPUT,/ 2X,6HNUMBER,2X,8HLOCATION,7X,
     1        8HSTRESSXX,7X,8HSTRESSYY,7X,8HSTRESSZZ,7X,8HSTRESSXY,
     2        7X,8HSTRESSXZ,7X,8HSTRESSYZ / 1X)
 2035 FORMAT (I8)
 2040 FORMAT (13X,I5,6E15.4)
 2055 FORMAT (//50H M A T E R I A L   A X I S   O R I E N T A T I O N ,
     1          3X,9HT A B L E,//28H    SET   NODE   NODE   NODE  ,/
     2          28H NUMBER     NI     NJ     NK      ,//)
 2057 FORMAT (4I7 / )
 2070 FORMAT (//40H S T R E S S   O U T P U T   T A B L E S    //
     1        10H     TABLE,6X,1H1,6X,1H2,6X,1H3,6X,1H4,6X,1H5,6X,1H6,
     2        6X,1H7,6X,1H8,6X,1H9,5X,2H10,5X,2H11,5X,2H12,5X,2H13,
     3        5X,2H14,5X,2H15,5X,2H16//)
 2060 FORMAT (I10,16I7)
 2090 FORMAT(44H *** STOP - INCORRECT NODAL DATA FOR EL. NO. ,I5)
 2400 FORMAT (///16H ELEMENT GROUP =,I2,23H  (3/D ELEMENT / THDFE)/
     1        19H ALTHOUGH NPAR(6) =,I2,22H, NONE OF THE ELEMENTS/
     2        49H IN THIS GROUP REFERS TO SKEW COORDINATE SYSTEMS./
     3        50H IT IS ADVISED THAT NPAR(6) BE SET TO ZERO TO SAVE,
     4        15H STORAGE SPACE.//
     5        39H THIS IS ONLY AN INFORMATIONAL MESSAGE.///)
 2410 FORMAT (///16H ELEMENT GROUP =,I2,23H  (3/D ELEMENT / THDFE)/
     1        16H ELEMENT NUMBER=,I4/10H NPAR(6) =,I2//
     2        53H SINCE NODES OF THIS ELEMENT REFER TO SKEW COORDINATE/
     3        37H SYSTEM(S), NPAR(6) MUST BE SET TO 1.//8H S T O P)
 3000 FORMAT (54H0 ***ERROR***  VECTOR IJ HAS ZERO LENGTH              )
 3010 FORMAT (54H0 ***ERROR***  VECTOR IK HAS ZERO LENGTH              )
 3020 FORMAT (54H0 ***ERROR***  IJ AND IK VECTORS ARE PARALELL         )
 3030 FORMAT (54H0 ***ERROR***  F3 AND F1 VECTORS ARE PARALELL         )
C
      END
C *CDC* *DECK MATWRT
C *UNI* )FOR,IS N.MATWRT,R.MATWRT
      SUBROUTINE MATWRT (N,DEN,PROP)
C
C
C     PROGRAM TO PRINT MATERIAL PROPERTIES
C              FOR THREE-DIMENSIONAL ELEMENTS
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      DIMENSION PROP(1)
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(16),NUMMAT),(NPAR(17),NCON)
     1           ,(NPAR(18),NORTHO),(NPAR(19),ITHERM),(NPAR(20),IDW)
C
C
      IF(IDATWR.LE.1) GO TO 500
      IF (MODEL.EQ.3 .OR. MODEL.EQ.5) GO TO 600
      IF (MODEL.EQ.7 .OR. MODEL.EQ.8 .OR. MODEL.EQ.9) GO TO 600
      IF (MODEL.EQ.10 .OR. MODEL.EQ.11) GO TO 600
      RETURN
C
  500 WRITE(6,2100) N,DEN
C
  600 GO TO (1,2,3,4,5,6,7,8,8,10,10,12),MODEL
C
C
C
C.... MODEL = 1    L I N E A R   I S O T R O P I C
C
    1 WRITE(6,2101) (PROP(I), I=1,NCON)
      RETURN
C
C
C.... MODEL = 2    L I N E A R   O R T H O T R O P I C
C
    2 WRITE(6,2102) (PROP(I),I=1,NCON)
      RETURN
C
C
C.... MODEL = 3    T H E R M O E L A S T I C
C
    3 IBUG=0
      NPTS=IDINT(PROP(65))
      IF(NPTS.GT.0) GO TO 60
      PROP(65)=16.0
      NPTS=16
      GO TO 72
C
   60 IF(NPTS.GE.2 .AND. NPTS.LE.16) GO TO 72
      IBUG=1
      WRITE(6,3002)
      GO TO 78
C
   72 DO 75 J=2,NPTS
      JJ=J-1
      IF(PROP(J).GT.PROP(JJ)) GO TO 75
      IBUG=1
      WRITE(6,3003)
      GO TO 78
   75 CONTINUE
C
   78 IF(IDATWR.GT.1) GO TO 85
      WRITE(6,2103)
      DO 80 K=1,16
      IP1=K + 16
      IP2=K + 32
      IP3=K + 48
   80 WRITE (6,2104) PROP(K),PROP(IP1),PROP(IP2),PROP(IP3)
      WRITE (6,2105) PROP(65),PROP(66)
C
   85 IF(MODEX.EQ.0.OR.IBUG.EQ.0) RETURN
      STOP
C
C
C.... MODEL = 4    C U R V E   D E S C R I P T I O N   M O D E L
C
    4 ICRACK=IDINT(PROP(25))
      WRITE (6,2220) ICRACK,(PROP(I),I=26,NCON)
      IP=NCON/4 - 1
      WRITE(6,2200)
      DO 20 I=1,IP
      IPI=I + IP
      IPI2= IPI + IP
      IPI3= IPI2 + IP
   20 WRITE (6,2210) I,PROP(I),PROP(IPI),PROP(IPI2),PROP(IPI3)
      RETURN
C
C
C.... MODEL = 5    C O N C R E T E   S T R U C T U R E   M O D E L
C
    5 IF (PROP(34).EQ.0.) PROP(34)=1.0
      IF (PROP(35).EQ.0.) PROP(35)=0.7
      IF (PROP(37).EQ.0.) PROP(37)=0.0001
      IF (PROP(38).EQ.0.) PROP(38)=0.5
      IF(IDATWR.GT.1) RETURN
C
      WRITE (6,2230) (PROP(I),I=1,8)
      IP1=8
      WRITE (6,2235) (PROP(IP1 + J),J=1,24)
      WRITE (6,2240) (PROP(J),J=33,38)
      RETURN
C
C
C.... MODEL .GE. 6   U S E R - S U P P L I E D   M A T E R I A L
C
C                 M O D E L
C
C
    6 GO TO 50
C
C
C.... MODEL = 7
C
    7 IBUG=0
      IF (PROP(4).GT.0.0) GO TO 141
      IBUG=1
      WRITE (6,3400) NG,N
  141 IF (IDATWR.LE.1) WRITE (6,2107) (PROP(I),I=1,NCON)
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) RETURN
      WRITE (6,3403)
      STOP
C
C
C.... MODELS = 8,9    E L A S T I C - P L A S T I C  (VON MISES)
C
    8 IF (NCON.GT.4) GO TO 200
C
C
      IBUG=0
      IF (PROP(3).GT.0.0) GO TO 150
      IBUG=1
      WRITE (6,3401) NG,N
  150 IF (PROP(4).LT.PROP(1)) GO TO 152
      IBUG=1
      WRITE (6,3402) NG,N
  152 CONTINUE
C
      IF (IDATWR.LE.1) WRITE (6,2106) (PROP(I),I=1,NCON)
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) RETURN
      WRITE (6,3403)
      STOP
C
  200 IF (IDATWR.GT.1) GO TO 160
      WRITE (6,2111) (PROP(I),I=1,3)
      WRITE (6,2112) PROP(3),PROP(4)
C
  160 IBUG=0
      IF (PROP(3).GT.0.0) GO TO 161
      IBUG=1
      WRITE (6,3401) NG,N
  161 ICP=4
      DO 165 I=1,6
      IF (PROP(ICP).EQ.0.0) GO TO 165
      ICP2=ICP+2
      IF (PROP(ICP).NE.PROP(ICP2)) GO TO 165
      IBUG=1
      WRITE (6,3404) NG,N,ICP,ICP2
  165 ICP=ICP+2
C
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) GO TO 167
      WRITE (6,3403)
      STOP
C
  167 DO 210 J=6,NCON,2
      ET=(PROP(J - 1) - PROP(J - 3))/(PROP(J) - PROP(J - 2))
      IF (IDATWR.LE.1) WRITE (6,2113) PROP(J-1),PROP(J),ET
  210 CONTINUE
      RETURN
C
C
C.... MODELS = 10,11    E L A S T I C - P L A S T I C + C R E E P
C
   10 IBUG=0
      NPTS=IDINT(PROP(105))
      XCRP=PROP(107)
      XINTP=PROP(108)
      XSUBM=PROP(109)
      XITE=PROP(110)
      XALG=PROP(111)
      TOLIL=PROP(112)
      TOLPC=PROP(113)
C
      IF(NPTS.GT.0) GO TO 95
      PROP(105)=16.0
      NPTS=16
C
   95 IF(XSUBM.EQ.0.0) PROP(109)=10.0
      IF(XALG.EQ.2.0.AND.XSUBM.LT.3.0) PROP(109)=3.0
      IF(XITE.EQ.0.0) PROP(110)=15.0
      IF(XALG.EQ.0.0) PROP(111)=1.0
      IF(TOLIL.EQ.0.0) PROP(112)=5.0D-3
      IF(TOLPC.EQ.0.0) PROP(113)=1.0D-1
C
      IF(XCRP.GE.0.0.AND.XCRP.LE.2.0) GO TO 100
      WRITE(6,3000)
      IBUG=1
C
  100 IF(XINTP.GE.0.0.AND.XINTP.LE.1.0) GO TO 102
      WRITE(6,3001)
      IBUG=1
C
  102 IF(NPTS.GE.2.AND.NPTS.LE.16) GO TO 104
      IBUG=1
      WRITE(6,3002)
      GO TO 110
C
  104 DO 106 J=2,NPTS
      JJ=J-1
      IF(PROP(J).GT.PROP(JJ)) GO TO 106
      IBUG=1
      WRITE(6,3003)
      GO TO 110
  106 CONTINUE
C
  110 IF(IDATWR.GT.1) GO TO 120
      WRITE (6,2301)
      DO 115 K=1,16
      IP1=K + 16
      IP2=K + 32
      IP3=K + 48
      IP4=K + 64
      IP5=K + 80
  115 WRITE (6,2302) PROP(K),PROP(IP1),PROP(IP2),PROP(IP3),PROP(IP4),
     1               PROP(IP5)
      WRITE (6,2303) (PROP(M),M=97,104)
      WRITE(6,2304) (PROP(M),M=105,113)
C
  120 IF(PROP(110).LT.6.0) WRITE(6,2305)
      IF(MODEX.EQ.0.OR.IBUG.EQ.0) RETURN
      STOP
C
   12 GO TO 50
C
   50 WRITE(6,2500) (I,PROP(I), I=1,NCON)
      RETURN
C
C
C
 1000 FORMAT (I5,4F10.0)
 1100 FORMAT (8F10.0)
 2100 FORMAT (30H MATERIAL CONSTANTS SET NUMBER,6H .... ,I5//,
     1        1H ,4X,29HDEN ..........( DENSITY ).. =, E14.6/)
 2101 FORMAT (1H ,4X,29HE ............( PROP(1) ).. =, E14.6/,
     1        1H ,4X,29HVNU ..........( PROP(2) ).. =, E14.6///)
 2102 FORMAT (1H ,4X,29HE(A) .........( PROP(1) ).. =, E14.6/,
     1        1H ,4X,29HE(B) .........( PROP(2) ).. =, E14.6/,
     2        1H ,4X,29HE(C) .........( PROP(3) ).. =, E14.6/,
     3        1H ,4X,29HVNU(AB) ......( PROP(4) ).. =, E14.6/,
     4        1H ,4X,29HVNU(AC) ......( PROP(5) ).. =, E14.6/,
     5        1H ,4X,29HVNU(BC) ......( PROP(6) ).. =, E14.6/,
     6        1H ,4X,29HG(AB) ........( PROP(7) ).. =, E14.6/,
     7        1H ,4X,29HG(AC) ........( PROP(8) ).. =, E14.6/,
     8        1H ,4X,29HG(BC) ........( PROP(9) ).. =, E14.6///)
 2103 FORMAT (1H ,4X,17HTEMP (PROP(1-16)),5X,15HE (PROP(17-32)),5X,
     1        17HVNU (PROP(33-48)),4X,19HALPHA (PROP(49-64)),/)
 2104 FORMAT (1H ,4X,4(E14.6,7X))
 2105 FORMAT ( //,4X,46HNUMBER OF TEMPERATURE POINTS ...(PROP(65)).. =,
     1        E14.6,/,
     2        1H ,3X,46HREFERENCE TEMPERATURE ..........(PROP(66)).. =,
     3        E14.6,//)
 2106 FORMAT (1H ,4X,29HE ............( PROP(1) ).. =,E14.6/
     1        1H ,4X,29HVNU ..........( PROP(2) ).. =,E14.6/
     2        1H ,4X,29HYIELD ........( PROP(3) ).. =,E14.6/
     3        1H ,4X,29HE (HARDEN) ...( PROP(4) ).. =,E14.6///)
 2107 FORMAT(1H ,4X,29HE ............( PROP(1) ).. =, E14.6/,
     1       1H ,4X,29HVNU ..........( PROP(2) ).. =, E14.6/,
     2       1H ,4X,29HALFA .........( PROP(3) ).. =, E14.6/,
     O       1H ,4X,29HK ............( PROP(4) ).. =, E14.6/,
     4       1H ,4X,29HW ............( PROP(5) ).. =, E14.6/,
     5       1H ,4X,29HD ............( PROP(6) ).. =, E14.6/,
     6       1H ,4X,29HT ............( PROP(7) ).. =, E14.6/,
     7       1H ,4X,29HI1A ..........( PROP(8) ).. =, E14.6///)
 2111 FORMAT (1H ,4X,29HE ............( PROP(1) ).. =,E14.6,/,
     1        1H ,4X,29HVNU ..........( PROP(2) ).. =,E14.6,/,
     2        1H ,4X,29HYIELD ........( PROP(3) ).. =,E14.6,//)
 2112 FORMAT (1H ,4X,36HPIECEWISE-LINEAR STRESS-STRAIN CURVE,/,
     1        1H ,6X,6HSTRESS,10X,6HSTRAIN,12X,2HET,//,
     2        6X,E14.6,2X,E14.6)
 2113 FORMAT (6X,3(E14.6,2X))
 2200 FORMAT (///
     1        19X,6HVOLUME,8X,7HLOADING,6X,9HUNLOADING,8X,7HLOADING, /
     2        19X,6HSTRAIN,2(3X,12HBULK MODULUS),2X,13HSHEAR MODULUS,
     3           / 1X)
 2210 FORMAT (7H POINT(,I1,2H) ,4E15.4)
 2220 FORMAT (35H CRACKING MODE . . . . . (ICRACK) =,I5,/
     1        43H    EQ.0, CURVE DESCRIPTION NONLINEAR MODEL    /,
     2        36H    EQ.1, SOIL MODFL WITH NO TENSION          /,
     3        48H    EQ.2, SOIL MODEL, NO TENSION, STRESS RELEASE    /,
     4        35H MATERIAL DENSITY . . . . . . . . =,E14.6,/,
     5        35H STIFFNESS REDUCTION FACTOR . . . =,E14.6,/,
     6        35H SHEAR REDUCTION FACTOR . . . . . =,E14.6,///)
 2230 FORMAT (//40H (A) UNIAXIAL PARAMETERS                ,
     1     //49H INITIAL TANGENT MODULUS . . . . . . . (PROP(1))=,E14.6,
     2      /49H POISSONS RATIO. . . . . . . . . . . . (PROP(2))=,E14.6,
     3      /49H COEFFICIENT OF THERMAL EXPANSION . . .(PROP(3))=,E14.6,
     4      /49H UNIAXIAL CUT-OFF TENSILE STRENGTH . .  (SIGMAT)=,E14.6,
     1      /49H UNIAXIAL MAXIMUM COMPRESSIVE STRESS . .(SIGMAC)=,E14.6,
     2      /49H COMPRESSIVE STRAIN AT SIGMAC . . . . . ( EPSC )=,E14.6,
     5      /49H UNIAXIAL ULTIMATE COMPRESSIVE STRESS . (SIGMAU)=,E14.6,
     8      /49H UNIAXIAL ULTIMATE COMPRESSIVE STRAIN . ( EPSU )=,E14.6)
 2235 FORMAT (//40H (B) TRIAXIAL COMPRESSIVE FAILURE CURVES,
     1        //4X,10H PRINCIPAL,5X,30X,12HCURVE NUMBER/1X,
     2        16H  STRESS RATIOS/,9X,3HI=1,10X,1H2,11X,1H3,11X,1H4,11X,
     3        1H5,11X,1H6/1X,90(1H-)//1X,6X,6HSP1(I),6X,6F12.4//1X,
     4        5X,8HSP3(I,1),5X,6F12.4,/1X,3X,12H(AT SP2=SP1),/1X,
     5        5X,8HSP3(I,2),5X,6F12.4,/2X,17H(AT SP2=BETA*SP3),/1X,
     6       5X,8HSP3(I,3),5X,6F12.4,/1X,3X,12H(AT SP2=SP3)//1X,90(1H-))
 2240 FORMAT (/40H (C) VARIOUS OTHER CONTROL PARAMETERS   //
     1      ,49H STRESS RATIO FOR FAILURE SURFACE INPUT .(BETA) =,E14.6/
     2      ,49H STRAINS SCALING FACTOR - MULTIAXIALITY .(GAMA) =,E14.6/
     3      ,49H CONTROL FOR CHANGING MATERIAL LAW . . . (KAPA) =,E14.6/
     4      ,49H CONTROL FOR LOADING/UNLOADING CRITERION (ALFA) =,E14.6/
     5      ,49H STIFFNESS REDUCTION FACTOR . . . . . .(STIFAC) =,E14.6/
     6      ,49H SHEAR REDUCTION FACTOR . . . . . . . .(SHEFAC) =,E14.6)
 2301 FORMAT (1H ,4X,17HTEMP (PROP(1-16)),5X,15HE (PROP(17-32)),5X,
     1        17HVNU (PROP(33-48)),3X,19HYIELD (PROP(49-64)),3X,
     2        16HET (PROP(65-80)),4X,19HALPHA (PROP(81-96)),/)
 2302 FORMAT (1H ,4X,6(E14.6,7X))
 2303 FORMAT (1H ,//,5X,33HCREEP LAW COEFFICIENTS ..........,//,
     1        1H ,4X,30HA0 ............(PROP(97 )).. =,E14.6,/,
     2        1H ,4X,30HA1 ............(PROP(98 )).. =,E14.6,/,
     3        1H ,4X,30HA2 ............(PROP(99 )).. =,E14.6,/,
     4        1H ,4X,30HA3 ............(PROP(100)).. =,E14.6,/,
     5        1H ,4X,30HA4 ............(PROP(101)).. =,E14.6,/,
     6        1H ,4X,30HA5 ............(PROP(102)).. =,E14.6,/,
     7        1H ,4X,30HA6 ............(PROP(103)).. =,E14.6,/,
     8        1H ,4X,30HA7 ............(PROP(104)).. =,E14.6,//)
 2304 FORMAT (1H ,4X,66HNUMBER OF TEMPERATURE POINTS ...................
     1...(PROP(105)).. =,E14.6,/,
     2        1H ,4X,66HREFERENCE TEMPERATURE ..........................
     3...(PROP(106)).. =,E14.6,/,
     4        1H ,4X,66HCREEP LAW KEY ..................................
     5...(PROP(107)).. =,E14.6,/,
     6        1H ,4X,66HINTEGRATION PARAMETER ..........................
     7...(PROP(108)).. =,E14.6,/,
     8        1H ,4X,66HMAXIMUM NUMBER OF SUBDIVISIONS .................
     9...(PROP(109)).. =,E14.6,/,
     A        1H ,4X,66HMAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION ...
     B...(PROP(110)).. =,E14.6,/,
     C        1H ,4X,66HALGORITHM INDICATOR ............................
     D...(PROP(111)).. =,E14.6,/,
     E        1H ,4X,66HCONVERGENCE TOLERANCE ..........................
     F...(PROP(112)).. =,E14.6,/,
     G        1H ,4X,66HINELASTIC STRAIN TOLERANCE .....................
     H...(PROP(113)).. =,E14.6,//)
 2305 FORMAT (1H ,4X,93HWARNING   THE USE OF PROP(110) .LT. 6 CAN RESULT
     1 IN A HIGHLY INACCURATE OR DIVERGENT SOLUTION)
 2500 FORMAT (1H ,4X,5HPROP(,I2,10H) ...... =,E14.6)
 3000 FORMAT (//,38H    ERROR   INCORRECT CREEP LAW NUMBER)
 3001 FORMAT (//,43H    ERROR   INCORRECT INTEGRATION PARAMETER)
 3002 FORMAT (//,50H    ERROR   INCORRECT NUMBER OF TEMPERATURE POINTS)
 3003 FORMAT (//,43H    ERROR   TEMPERATURE POINTS OUT OF ORDER)
 3400 FORMAT (//50H INPUT ERROR DETECTED IN (MATWRT/3D SOLID)         //
     1          19H ELEMENT GROUP NO = ,I5/
     2          27H MATERIAL PROPERTY SET NO = ,I5/
     4          50H YIELD FUNCTION PARAMETER K SHOULD BE GREATER      /
     5          20H THAN ZERO.            //)
 3401 FORMAT (//50H INPUT ERROR DETECTED IN (MATWRT/3D SOLID)         //
     1          19H ELEMENT GROUP NO = ,I5/
     2          27H MATERIAL PROPERTY SET NO = ,I5/
     2          38H ZERO OR NEGATIVE INITIAL YIELD STRESS  //)
 3402 FORMAT (//50H INPUT ERROR DETECTED IN (MATWRT/3D SOLID)         //
     1          19H ELEMENT GROUP NO = ,I5/
     2          27H MATERIAL PROPERTY SET NO = ,I5/
     3          44H HARDENING MODULUS (ET) GREATER OR EQUAL TO  ,
     4          44H YOUNG*S MODULUS (E) IS NOT ALLOWED          //)
 3403 FORMAT (//50H INPUT ERROR IN MATERIAL PROPERTIES                //
     1          15H  *** STOP ***   //)
 3404 FORMAT (//50H INPUT ERROR DETECTED IN (MATWRT/3D SOLID)         //
     4          19H ELEMENT GROUP NO = ,I5/
     3          27H MATERIAL PROPERTY SET NO = ,I5/
     2          42H IN THE MULTILINEAR ELASTIC-PLASTIC MODEL  /
     1          6H PROP(,I2,14H) EQUALS PROP(,I2,16H) IS NOT ALLOWED //)
C
C
      END
C *CDC* *DECK CAUCH3
C *UNI* )FOR,IS N.CAUCH3, R.CAUCH3
      SUBROUTINE CAUCH3
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .     CONVERTS PIOLA-KIRCHOFF STRESSES                              .
C .          TO CAUCHY STRESSES                                       .
C .                                                                   .
C .     CS  =  (1./DET(F))  *  (F * PK * F(TRANSPOSED)                .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISDR/ DISD(9)
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
C
      F11=DISD(1) + 1.
      F12=DISD(4)
      F13=DISD(5)
      F21=DISD(6)
      F22=DISD(2) + 1.
      F23=DISD(7)
      F31=DISD(8)
      F32=DISD(9)
      F33=DISD(3) + 1.
C
      DET=    F11*F22*F33 + F12*F23*F31 + F13*F32*F21
      DET=DET-F13*F22*F31 - F23*F32*F11 - F33*F21*F12
      IF (DET.GT.0.) GO TO 760
      WRITE (6,2100) NEL,DET
      STOP
C
  760 DET=1.0/DET
      S11=STRESS(1)
      S22=STRESS(2)
      S33=STRESS(3)
      S12=STRESS(4)
      S13=STRESS(5)
      S23=STRESS(6)
C
      PKFT1=S11*F11 + S12*F12 + S13*F13
      PKFT2=S12*F11 + S22*F12 + S23*F13
      PKFT3=S13*F11 + S23*F12 + S33*F13
      STRESS(1)= DET*(F11*PKFT1 + F12*PKFT2 + F13*PKFT3)
      STRESS(4)= DET*(F21*PKFT1 + F22*PKFT2 + F23*PKFT3)
      STRESS(5)= DET*(F31*PKFT1 + F32*PKFT2 + F33*PKFT3)
C
      PKFT1=S11*F21 + S12*F22 + S13*F23
      PKFT2=S12*F21 + S22*F22 + S23*F23
      PKFT3=S13*F21 + S23*F22 + S33*F23
      STRESS(2)= DET*(F21*PKFT1 + F22*PKFT2 + F23*PKFT3)
C
      PKFT1=S11*F31 + S12*F32 + S13*F33
      PKFT2=S12*F31 + S22*F32 + S23*F33
      PKFT3=S13*F31 + S23*F32 + S33*F33
      STRESS(3)= DET*(F31*PKFT1 + F32*PKFT2 + F33*PKFT3)
      STRESS(6)= DET*(F21*PKFT1 + F22*PKFT2 + F23*PKFT3)
C
      RETURN
 2100 FORMAT (40H DETERMINANT NOT POSITIVE FOR ELEMENT = ,I4,/
     1        14H DETERMINANT =,E14.6/8H ***STOP)
      END
C *CDC* *DECK INTWA3
C *UNI* )FOR,IS  N.INTWA3, R.INTWA3
      SUBROUTINE INTWA3 (MODEL)
C
C     INITIALIZES WORKING VECTOR WA FOR THIS ELEMENT
C
      GO TO (1,2,3,4,4,6,7,8,8,10,10,12), MODEL
C
C
C     M O D E L   1     LINEAR ISOTROPIC
C
    1 RETURN
C
C     M O D E L   2     LINEAR ORTHOTROPIC
C
    2 RETURN
C
C     M O D E L   3     THERMOELASTIC MODEL
C
C *CDC*     3 CALL OVERLAY (5HADINA,4,1,6HRECALL)
    3 CALL ELT3D3
      RETURN
C
C     M O D E L   4    CURVE DESCRIPTION NONLINEAR MODEL
C     M O D E L   5    CONCRETE CRACKING MODEL
C
C *CDC*     4 CALL OVERLAY (5HADINA,4,2,6HRECALL)
    4 CALL ELT3D4
      RETURN
C
C     M O D E L   6     (EMPTY)
C
C *CDC*     6 CALL OVERLAY (5HADINA,4,3,6HRECALL)
    6 CALL ELT3D6
      RETURN
C
C     M O D E L  7    ELASTIC-PLASTIC (DRUCKER-PRAGER MODEL)
C
C *CDC*     7 CALL OVERLAY (5HADINA,4,4,6HRECALL)
    7 CALL ELT3D7
      RETURN
C
C     M O D E L   8    ELASTIC-PLASTIC (VON MISES / ISOTROPIC HARDENING)
C     M O D E L   9    ELASTIC-PLASTIC (VON MISES / KINEMATIC HARDENING)
C
C *CDC*     8 CALL OVERLAY (5HADINA,4,5,6HRECALL)
    8 CALL ELT3D8
      RETURN
C
C     M O D E L   10    ELASTIC-PLASTIC WITH CREEP (ISOTROPIC)
C     M O D E L   11    ELASTIC-PLASTIC WITH CREEP (KINEMATIC)
C
C *CDC*    10 CALL OVERLAY (5HADINA,4,6,6HRECALL)
   10 CALL EL3D10
      RETURN
C
C
C     M O D E L   12-16    (EMPTY)
C
C *CDC*    12 CALL OVERLAY (5HADINA,4,7,6HRECALL)
   12 CALL EL3D12
      RETURN
C
      END
C *CDC* *DECK QUADS3
C *UNI* )FOR,IS  N.QUADS3, R.QUADS3
      SUBROUTINE QUADS3 (ND,B,S,XYZ,PROP,DCA,RE,EDIS,EDISI,WA,NOD9,
     1                   MAXES)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .      HEXAHEDRAL CURVILINEAR THREE-DIMENSIONAL ELEMENTS            .
C .                                                                   .
C .      ISOPARAMETRIC OR SUBPARAMETRIC                               .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION B(1),S(1),XYZ(1),PROP(1),DCA(3,3),RE(1),EDIS(1),
     1          EDISI(1),WA(1),NOD9(1)
      DIMENSION DISD(9),TAU(6),XXX(63),BV(378),DI(6,6)
C
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(10),NINT),(NPAR(11),NINTZ),
     1            (NPAR(15),MODEL)
C
C
      IF (IND.GE.4) GO TO 100
C
C
C     F I N D  S T I F F N E S S  O F  L I N E A R  E L E M E N T
C
C
C
C     INTEGRATE B(TRANSPOSED) * B
C
      DO 30 LX=1,NINT
      E1=XG(LX,NINT)
      DO 30 LY=1,NINT
      E2=XG(LY,NINT)
      DO 30 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      WT=WGT(LX,NINT)*WGT(LY,NINT)*WGT(LZ,NINTZ)
C
C     EVALUATE STRAIN-DISPLACEMENT MATRIX B AND JACOBIAN DETERMINANT
C     AT THIS INTEGRATION POINT
C
      CALL DERIQ3 (NEL,XYZ,B,DET,E1,E2,E3,NOD9)
C
      FAC=WT*DET
      FAC=DSQRT(FAC)
      DO 10 I=1,ND
 10   B(I)=FAC*B(I)
      KL=0
      DO 20 I=1,ND
      DO 20 J=I,ND
      KL=KL+1
 20   S(KL)=S(KL)+B(I)*B(J)
 30   CONTINUE
C
C     MULTIPLY D BY THE INTEGRATED B(TRANSPOSED) * B
C
      CALL STST3L (NEL,XYZ,PROP,DCA,D,MAXES)
C
      CALL BTDB(B,D,S,MODEL,ND,1)
C
      RETURN
C
C
C     F I N D   N O N L I N E A R   E L E M E N T   M A T R I C E S
C
C
 100  IF (INDNL.LE.2) GO TO 120
      DO 110 J=1,ND
 110  XXX(J)=XYZ(J)+EDIS(J)
C
C     EVALUATE STRESS-STRAIN LAW IF LINEAR MATERIAL MODEL
C     USED IN THIS ELEMENT
C
 120  IF (MODEL.GT.2) GO TO 140
      IF (INDNL.LE.2) GO TO 130
      CALL STST3L (NEL,XXX,PROP,DCA,D,MAXES)
      GO TO 140
 130  CALL STST3L (NEL,XYZ,PROP,DCA,D,MAXES)
C
C
C     INTEGRATE STIFFNESS MATRIX AND ELEMENT NODAL FORCE EXPRESSION
C
C
  140 IPT=0
      DO 470 LX=1,NINT
      E1=XG(LX,NINT)
      DO 470 LY=1,NINT
      E2=XG(LY,NINT)
      DO 470 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      WT=WGT(LX,NINT)*WGT(LY,NINT)*WGT(LZ,NINTZ)
      IPT=IPT+1
      IF (INDNL.EQ.3) GO TO 310
C
C
C     T O T A L   L A G R A N G I A N   F O R M U L A T I O N
C
C
C     EVALUATE DERIVATIVE OPERATOR B (IN COMPACTED FORM)
C
      CALL DERIQ3 (NEL,XYZ,B,DET,E1,E2,E3,NOD9)
C
C
      DO 150 I=1,9
 150  DISD(I)=0.0
C
      DO 160 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1)+B(K)*EDIS(K)
      DISD(2)=DISD(2)+B(I)*EDIS(I)
      DISD(3)=DISD(3)+B(J)*EDIS(J)
      DISD(4)=DISD(4)+B(I)*EDIS(K)
      DISD(5)=DISD(5)+B(J)*EDIS(K)
      DISD(6)=DISD(6)+B(K)*EDIS(I)
      DISD(7)=DISD(7)+B(J)*EDIS(I)
      DISD(8)=DISD(8)+B(K)*EDIS(J)
 160  DISD(9)=DISD(9)+B(I)*EDIS(J)
C
C     EVALUATE STRESS-STRAIN LAW AND CURRENT STRESSES
C
      CALL STST3N (DISD)
C
      IF (INDNL.LE.1) GO TO 332
C
C     EVALUATE DERIVATIVE OPERATOR INCLUDING THE INITIAL
C     DISPLACEMENT EFFECTS
C
      DO 63 K=3,ND,3
      J=K-1
      I=K-2
      L=6*I-5
      M=L+6
      N=M+6
C
      BV(L)=B(I)*DISD(1)+B(I)
      BV(L+1)=B(J)*DISD(4)
      BV(L+2)=B(K)*DISD(5)
      BV(L+3)=B(I)*DISD(4)+B(J)*DISD(1)+B(J)
      BV(L+4)=B(I)*DISD(5)+B(K)*DISD(1)+B(K)
      BV(L+5)=B(J)*DISD(5)+B(K)*DISD(4)
C
      BV(M)=B(I)*DISD(6)
      BV(M+1)=B(J)*DISD(2)+B(J)
      BV(M+2)=B(K)*DISD(7)
      BV(M+3)=B(I)*DISD(2)+B(J)*DISD(6)+B(I)
      BV(M+4)=B(I)*DISD(7)+B(K)*DISD(6)
      BV(M+5)=B(J)*DISD(7)+B(K)*DISD(2)+B(K)
C
      BV(N)=B(I)*DISD(8)
      BV(N+1)=B(J)*DISD(9)
      BV(N+2)=B(K)*DISD(3)+B(K)
      BV(N+3)=B(I)*DISD(9)+B(J)*DISD(8)
      BV(N+4)=B(I)*DISD(3)+B(K)*DISD(8)+B(I)
      BV(N+5)=B(J)*DISD(3)+B(K)*DISD(9)+B(J)
 63   CONTINUE
C
C     ADD STRESS CONTRIBUTION TO ELEMENT FORCE VECTOR
C
      FAC=WT*DET
      DO 170 I=1,6
 170  TAU(I)=STRESS(I)*FAC
      DO 180 K=3,ND,3
      I=K-2
      J=K-1
      L=6*I-6
      M=L+6
      N=L+12
      DO 179 II=1,6
      RE(I)=RE(I) + BV(L+II)*TAU(II)
      RE(J)=RE(J) + BV(M+II)*TAU(II)
  179 RE(K)=RE(K) + BV(N+II)*TAU(II)
  180 CONTINUE
C
      IF (ICOUNT-2) 190,190,470
 190  IF (IREF) 470,200,470
C
C     ADD LINEAR CONTRIBUTION TO ELEMENT STIFFNESS MATRIX
C
C        ISOTROPIC VERSION OF B(TRANSPOSED)*D*B
C
  200 IF (MODEL.NE.1 .AND. MODEL.NE.3) GO TO 300
      D11=D(1,1)*FAC
      D12=D(1,2)*FAC
      D44=D(4,4)*FAC
      N=1
      DO 83 J=1,ND
      K=6*(J-1)
      DB1=D11*BV(K+1)+D12*(BV(K+2)+BV(K+3))
      DB2=D11*BV(K+2)+D12*(BV(K+1)+BV(K+3))
      DB3=D11*BV(K+3)+D12*(BV(K+1)+BV(K+2))
      DB4=D44*BV(K+4)
      DB5=D44*BV(K+5)
      DB6=D44*BV(K+6)
C
      DO 73 I=J,ND
      K=6*(I-1)
      S(N)=S(N) + DB1*BV(K+1) + DB2*BV(K+2) + DB3*BV(K+3) + DB4*BV(K+4)
     1          + DB5*BV(K+5) + DB6*BV(K+6)
 73   N=N+1
 83   CONTINUE
      GO TO 465
C
C         ORTHOTROPIC VERSION OF B(TRANSPOSED)*D*B
C
  300 DO 301 I=1,6
      DO 301 J=1,6
  301 DI(I,J)=D(I,J)*FAC
      N=1
      DO 308 J=1,ND
      K=6*(J-1)
      DB1=0.
      DB2=0.
      DB3=0.
      DB4=0.
      DB5=0.
      DB6=0.
C
      DO 302 L=1,6
      DB1=DB1+BV(K+L)*DI(L,1)
      DB2=DB2+BV(K+L)*DI(L,2)
      DB3=DB3+BV(K+L)*DI(L,3)
      DB4=DB4+BV(K+L)*DI(L,4)
      DB5=DB5+BV(K+L)*DI(L,5)
      DB6=DB6+BV(K+L)*DI(L,6)
  302 CONTINUE
C
      DO 305 I=J,ND
      M=6*(I-1)
      S(N)=S(N)+DB1*BV(M+1)+DB2*BV(M+2)+DB3*BV(M+3)+DB4*BV(M+4)+
     1 DB5*BV(M+5)+DB6*BV(M+6)
  305 N=N+1
  308 CONTINUE
      GO TO 465
C
C
C     U P D A T E D    L A G R A N G I A N    F O R M U L A T I O N
C
C
C     EVALUATE DERIVATIVE OPERATOR B (IN COMPACTED FORM)
C
 310  CALL DERIQ3 (NEL,XXX,B,DET,E1,E2,E3,NOD9)
C
C
      DO 320 I=1,9
 320  DISD(I)=0.0
C
C     CALCULATE DISPLACEMENT DERIVATIVES
C
C        1. FOR MODEL = 1, USE ALMANSI STRAINS
C
      IF (MODEL.GT.1) GO TO 335
      DO 330 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1)+B(K)*EDIS(K)
      DISD(2)=DISD(2)+B(I)*EDIS(I)
      DISD(3)=DISD(3)+B(J)*EDIS(J)
      DISD(4)=DISD(4)+B(I)*EDIS(K)
      DISD(5)=DISD(5)+B(J)*EDIS(K)
      DISD(6)=DISD(6)+B(K)*EDIS(I)
      DISD(7)=DISD(7)+B(J)*EDIS(I)
      DISD(8)=DISD(8)+B(K)*EDIS(J)
 330  DISD(9)=DISD(9)+B(I)*EDIS(J)
      GO TO 337
C
C        2. FOR PLASTICITY AND CREEP MODELS (U.L.J. FORMULATION)
C           USE STRAIN INCREMENTS
C
  335 DO 336 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1) + B(K)*EDISI(K)
      DISD(2)=DISD(2) + B(I)*EDISI(I)
      DISD(3)=DISD(3) + B(J)*EDISI(J)
      DISD(4)=DISD(4) + B(I)*EDISI(K)
      DISD(5)=DISD(5) + B(J)*EDISI(K)
      DISD(6)=DISD(6) + B(K)*EDISI(I)
      DISD(7)=DISD(7) + B(J)*EDISI(I)
      DISD(8)=DISD(8) + B(K)*EDISI(J)
  336 DISD(9)=DISD(9) + B(I)*EDISI(J)
C
C     EVALUATE STRESS-STRAIN LAW AND CURRENT STRESSES
C
  337 CALL STST3N (DISD)
C
C     ADD STRESS CONTRIBUTION TO ELEMENT FORCE VECTOR
C
  332 FAC=WT*DET
      DO 340 I=1,6
 340  TAU(I)=STRESS(I)*FAC
      DO 350 K=3,ND,3
      I=K-2
      J=K-1
      RE(I)=RE(I)+B(I)*TAU(1)+B(J)*TAU(4)+B(K)*TAU(5)
      RE(J)=RE(J)+B(J)*TAU(2)+B(I)*TAU(4)+B(K)*TAU(6)
      RE(K)=RE(K)+B(K)*TAU(3)+B(I)*TAU(5)+B(J)*TAU(6)
  350 CONTINUE
C
      IF (ICOUNT-2) 360,360,470
 360  IF (IREF) 470,370,470
C
C     ADD LINEAR CONTRIBUTION TO ELEMENT STIFFNESS MATRIX
C
  370 DO 380 I=1,6
      DO 380 J=1,6
  380 DI(I,J)=D(I,J)*FAC
C
      CALL BTDB (B,DI,S,MODEL,ND,2)
C
C
C     T O T A L  A N D  U P D A T E D  F O R M U L A T I O N S
C
C
C     ADD NONLINEAR CONTRIBUTION TO STIFFNESS MATRIX
C
C
  465 IF (INDNL.EQ.1) GO TO 470
      KL=1
      DO 491 J=1,ND,3
      DB1=TAU(1)*B(J) + TAU(4)*B(J+1) + TAU(5)*B(J+2)
      DB2=TAU(4)*B(J) + TAU(2)*B(J+1) + TAU(6)*B(J+2)
      DB3=TAU(5)*B(J) + TAU(6)*B(J+1) + TAU(3)*B(J+2)
      KS1=KL
      KS2=KS1+ND-J+1
      KS3=KS2+ND-J
      DO 490 I=J,ND,3
      DUM=B(I)*DB1 + B(I+1)*DB2 + B(I+2)*DB3
      S(KS1)=S(KS1) + DUM
      S(KS2)=S(KS2) + DUM
      S(KS3)=S(KS3) + DUM
      KS1=KS1+3
      KS2=KS2+3
  490 KS3=KS3+3
  491 KL=KL+3*ND-3*J
C
  470 CONTINUE
C
      RETURN
C
C
      END
C *CDC* *DECK BTDB
C *UNI* )FOR, IS N.BTDB, R.BTDB
      SUBROUTINE BTDB(B,D,S,MODEL,ND,ICODE)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      TO MULTIPLY D BY B(TRANSPOSED)*B                             .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION B(1),D(6,1),S(1),DS(9),BB(9),IPERM(3,3),KDX(3),LDX(3)
      DATA IPERM/ 1,4,5, 4,2,6, 5,6,3/
C
      IND=1
      IF (MODEL.EQ.1 .OR. MODEL.EQ.3) GO TO 20
C
C     CHECK FOR THE ORTHOTROPY OF THE MATERIAL
C
      DUM=0.0
      DO 10 I=4,6
      J=I-1
      DO 10 K=1,J
   10 DUM=DUM + DABS(D(K,I))
      IF (DUM.GT.1.0D-06) IND=2
      IF (IND.EQ.2) GO TO 20
      DUM=DABS(D(2,2)-D(1,1)) + DABS(D(3,3)-D(2,2)) + DABS(D(5,5)-D(4,4)
     1)+ DABS(D(6,6)-D(5,5)) + DABS(D(1,2)-D(2,3)) + DABS(D(2,3)-D(1,3))
      IF (DUM.GT.1.0D-06) IND=2
C
   20 IEL=ND/3
      D1=D(1,1)
      D2=D(1,2)
      D3=D(4,4)
      KL=1
      DO 85 II=1,IEL
      I0=3*(II-1)
      DO 80 JJ=II,IEL
      J0=3*(JJ-1)
C
      IF (ICODE.EQ.1) GO TO 35
C
C     LINEAR CONTRIBUTION TO NONLINEAR STIFFNESS MATRIX
C
      KS=KL
      IC=0
      DO 30 I=1,3
      DO 25 J=1,3
      IC=IC+1
      BB(IC)=B(I0+I)*B(J0+J)
      IF (II.EQ.JJ .AND. I.GT.J) GO TO 25
      DS(IC)=S(KS)
   25 KS=KS+1
   30 KS=KS+ND-I0-I-3
      GO TO 55
C
C     LINEAR STIFFNESS MATRIX
C
   35 KS=KL
      IC=0
      DO 50 I=1,3
      DO 40 J=1,3
      IC=IC+1
      BB(IC)=S(KS)
   40 KS=KS+1
   50 KS=KS+ND-I0-I-3
C
   55 IF (IND.EQ.2) GO TO 90
C
C     ISOTROPIC CASE
C
      KS1=KL
      KS2=KS1+ND-I0-1
      KS3=KS2+ND-I0-2
      S(KS1)=BB(1)*D1+(BB(5)+BB(9))*D3
      S(KS2+1)=BB(5)*D1+(BB(1)+BB(9))*D3
      S(KS3+2)=BB(9)*D1+(BB(1)+BB(5))*D3
      IF (II.EQ.JJ) GO TO 60
      S(KS1+1)=BB(2)*D2+BB(4)*D3
      S(KS2)=BB(4)*D2+BB(2)*D3
      S(KS1+2)=BB(3)*D2+BB(7)*D3
      S(KS3)=BB(7)*D2+BB(3)*D3
      S(KS2+2)=BB(6)*D2+BB(8)*D3
      S(KS3+1)=BB(8)*D2+BB(6)*D3
      GO TO 65
   60 S(KS1+1)=BB(2)*(D2+D3)
      S(KS1+2)=BB(3)*(D2+D3)
      S(KS2+2)=BB(6)*(D2+D3)
      GO TO 65
C
C     ORTHOTROPIC CASE
C
   90 IF (II.NE.JJ) GO TO 91
      BB(4)=BB(2)
      BB(7)=BB(3)
      BB(8)=BB(6)
   91 KS=KL
      DO 97 K=1,3
      DO 93 IJ=1,3
   93 KDX(IJ)=IPERM(IJ,K)
      DO 96 L=1,3
      IF (II.EQ.JJ .AND. K.GT.L) GO TO 96
      DO 94 IJ=1,3
   94 LDX(IJ)=IPERM(IJ,L)
C
      SUM=0.0
      IC=0
      DO 95 I=1,3
      K1=KDX(I)
      DO 95 J=1,3
      K2=LDX(J)
      IC=IC+1
   95 SUM=SUM+BB(IC)*D(K1,K2)
      S(KS)=SUM
   96 KS=KS+1
   97 KS=KS+ND-I0-K-3
C
   65 IF (ICODE.EQ.1) GO TO 80
      IC=0
      KS=KL
      DO 75 I=1,3
      DO 70 J=1,3
      IC=IC+1
      IF (II.EQ.JJ .AND. I.GT.J) GO TO 70
      S(KS)=S(KS)+DS(IC)
   70 KS=KS+1
   75 KS=KS+ND-I0-I-3
C
   80 KL=KL+3
   85 KL=KL+2*(ND-I0)-3
C
      RETURN
      END
C *CDC* *DECK QUADM3
C *UNI* )FOR,IS  N.QUADM3, R.QUADM3
      SUBROUTINE QUADM3  (N,ND,NDM2,XM,CM,XX,NOD9)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      EVALUATES MASS MATRIX                                        .
C .                                                                   .
C .      CURVILINEAR HEXAHEDRON   8 TO 21 NODES                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      DIMENSION XM(1),CM(1),XX(3,1),D(63),                 NOD9(1)
      DIMENSION H(21),P(3,21),XJ(3,3)
C
C
C     INTEGRATE USING GAUSS QUADRATURE
C
C
      IINTP=0
      NINTM=3
      NINTZM=3
      IF (IMASS.EQ.1) GO TO 9
      DO 8 I=1,NDM2
    8 CM(I)=0.0
      GO TO 10
    9 DO 7 I=1,ND
    7 XM(I)=0.
C
   10 DO 900 LX=1,NINTM
      R=XG(LX,NINTM)
      DO 900 LY=1,NINTM
      S=XG(LY,NINTM)
      DO 900 LZ=1,NINTZM
      T=XG(LZ,NINTZM)
      WT=WGT(LX,NINTM)*WGT(LY,NINTM)*WGT(LZ,NINTZM)
C
C
C     FIND INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     FIND JACOBIAN MATRIX AND ITS DETERMINANT
C
C
      CALL FUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C     CONSISTENT MASS MATRIX
C
C
      FAC=WT*DET*DE
      IF (IMASS.LT.2) GO TO 320
      DO 200 I=1,IEL
      D(3*I - 2)=H(I)
      D(3*I - 1)=H(I)
  200 D(3*I)=H(I)
      KL=1
      DO 300 I=1,ND,3
      DO 301 J=I,ND,3
      CM(KL)=CM(KL) + D(I)*D(J)*FAC
  301 KL=KL + 3
  300 KL=KL + 2*(ND-I) - 1
      GO TO 900
C
C
C     LUMPED MASS VECTOR
C
C
  320 DO 325 I=1,ND,3
      FACM=FAC/IEL
  325 XM(I)=XM(I) + FACM
C
  900 CONTINUE
C
      IF (IMASS.EQ.1) GO TO 335
      KL=1
      DO 450 I=1,ND,3
      KS1=KL + ND - I + 1
      KS2=KS1 + ND - I
      DO 451 J=I,ND,3
      CM(KS1)=CM(KL)
      CM(KS2)=CM(KL)
      KL=KL + 3
      KS1=KS1 + 3
  451 KS2=KS2 + 3
  450 KL=KL + 2*(ND-I) - 1
      RETURN
C
  335 DO 340 I=1,ND,3
      XM(I+1)=XM(I)
  340 XM(I+2)=XM(I)
      RETURN
      END
C *CDC* *DECK DERIQ3
C *UNI* )FOR,IS  N.DERIQ3, R.DERIQ3
      SUBROUTINE DERIQ3  (NEL,XX,B,DET,R,S,T,NOD9)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      EVALUATES STRAIN-DISPLACEMENT MATRIX B AT POINT (R,S,T)      .
C .                                                                   .
C .      CURVILINEAR HEXAHEDRON   8 TO 21 NODES                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      DIMENSION XX(3,1),B(1),NOD9(1)
      DIMENSION H(21),P(3,21),XJ(3,3),XJI(3,3)
C
C
C     FIND INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     EVALUATE JACOBIAN MATRIX AT POINT (R,S,T)
C     COMPUTE DETERMINANT OF JACOBIAN MATRIX AT POINT (R,S,T)
C
C
      IINTP=0
      CALL FUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C     COMPUTE INVERSE OF JACOBIAN MATRIX
C
C
      DUM=1.0/DET
      XJI(1,1)=DUM*( XJ(2,2)*XJ(3,3) - XJ(2,3)*XJ(3,2))
      XJI(2,1)=DUM*(-XJ(2,1)*XJ(3,3) + XJ(2,3)*XJ(3,1))
      XJI(3,1)=DUM*( XJ(2,1)*XJ(3,2) - XJ(2,2)*XJ(3,1))
      XJI(1,2)=DUM*(-XJ(1,2)*XJ(3,3) + XJ(1,3)*XJ(3,2))
      XJI(2,2)=DUM*( XJ(1,1)*XJ(3,3) - XJ(1,3)*XJ(3,1))
      XJI(3,2)=DUM*(-XJ(1,1)*XJ(3,2) + XJ(1,2)*XJ(3,1))
      XJI(1,3)=DUM*( XJ(1,2)*XJ(2,3) - XJ(1,3)*XJ(2,2))
      XJI(2,3)=DUM*(-XJ(1,1)*XJ(2,3) + XJ(1,3)*XJ(2,1))
      XJI(3,3)=DUM*( XJ(1,1)*XJ(2,2) - XJ(1,2)*XJ(2,1))
C
C
C     EVALUATE B MATRIX IN GLOBAL (X,Y,Z) COORDINATES
C
C
      DO 130 K=1,IEL
      K2=K*3
      DO 125 I=1,3
  125 B(K2+1-I)=0.0
      DO 120 I=1,3
      B(K2-2)=B(K2-2) + XJI(1,I)*P(I,K)
      B(K2-1)=B(K2-1) + XJI(2,I)*P(I,K)
  120 B(K2)=B(K2) + XJI(3,I)*P(I,K)
  130 CONTINUE
C
C
      RETURN
C
      END
C *CDC* *DECK FUNCT
C *UNI* )FOR,IS  N.FUNCT,  R.FUNCT
      SUBROUTINE FUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      TO FIND INTERPOLATION FUNCTIONS ( H )                        .
C .      AND DERIVATIVES ( P ) CORRESPONDING TO THE NODAL             .
C .      POINTS OF A CURVILINEAR ISOPARAMETRIC HEXAHEDRON             .
C .      OR SUBPARAMETRIC HEXAHEDRON (8 TO 21 NODES)                  .
C .                                                                   .
C .      TO FIND JACOBIAN ( XJ ) AND ITS DETERMINANT ( DET )          .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /VAR/   NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,IREF,
     1               IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      DIMENSION H(1),P(3,1),NOD9(1),IPERM(8),XJ(3,3),XX(3,1)
      EQUIVALENCE (NPAR(8),IDEGEN)
C
      DATA IPERM / 2,3,4,1,6,7,8,5 /
C
      RP=1.0 + R
      SP=1.0 + S
      TP=1.0 + T
      RM=1.0 - R
      SM=1.0 - S
      TM=1.0 - T
      RR=1.0 - R*R
      SS=1.0 - S*S
      TT=1.0 - T*T
C
C
C     INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C
C
C     8-NODE BRICK
C
      H(1)=0.125*RP*SP*TP
      H(2)=0.125*RM*SP*TP
      H(3)=0.125*RM*SM*TP
      H(4)=0.125*RP*SM*TP
      H(5)=0.125*RP*SP*TM
      H(6)=0.125*RM*SP*TM
      H(7)=0.125*RM*SM*TM
      H(8)=0.125*RP*SM*TM
C
      P(1,1)= 0.125*SP*TP
      P(1,2)=-P(1,1)
      P(1,3)=-0.125*SM*TP
      P(1,4)=-P(1,3)
      P(1,5)= 0.125*SP*TM
      P(1,6)=-P(1,5)
      P(1,7)=-0.125*SM*TM
      P(1,8)=-P(1,7)
C
      P(2,1)= 0.125*RP*TP
      P(2,2)= 0.125*RM*TP
      P(2,3)=-P(2,2)
      P(2,4)=-P(2,1)
      P(2,5)= 0.125*RP*TM
      P(2,6)= 0.125*RM*TM
      P(2,7)=-P(2,6)
      P(2,8)=-P(2,5)
C
      P(3,1)= 0.125*RP*SP
      P(3,2)= 0.125*RM*SP
      P(3,3)= 0.125*RM*SM
      P(3,4)= 0.125*RP*SM
      P(3,5)=-P(3,1)
      P(3,6)=-P(3,2)
      P(3,7)=-P(3,3)
      P(3,8)=-P(3,4)
C
      IF (IEL.EQ.8) GO TO 80
C
C
C     ADD DEGREES OF FREEDOM IN EXCESS OF 8
C
      I=0
    2 I=I + 1
      IF (I.GT.NND9) GO TO 40
      NN=NOD9(I) - 8
      GO TO (9,10,11,12,13,14,15,16,17,18,19,20,21) ,NN
C
    9 H(9) =0.25*RR*SP*TP
      P(1,9) =-0.50*R*SP*TP
      P(2,9) = 0.25*RR*TP
      P(3,9) = 0.25*RR*SP
      GO TO 2
   10 H(10)=0.25*RM*SS*TP
      P(1,10)=-0.25*SS*TP
      P(2,10)=-0.50*RM*S*TP
      P(3,10)= 0.25*RM*SS
      GO TO 2
   11 H(11)=0.25*RR*SM*TP
      P(1,11)=-0.50*R*SM*TP
      P(2,11)=-0.25*RR*TP
      P(3,11)= 0.25*RR*SM
      GO TO 2
   12 H(12)=0.25*RP*SS*TP
      P(1,12)= 0.25*SS*TP
      P(2,12)=-0.50*RP*S*TP
      P(3,12)= 0.25*RP*SS
      GO TO 2
   13 H(13)=0.25*RR*SP*TM
      P(1,13)=-0.50*R*SP*TM
      P(2,13)= 0.25*RR*TM
      P(3,13)=-0.25*RR*SP
      GO TO 2
   14 H(14)=0.25*RM*SS*TM
      P(1,14)=-0.25*SS*TM
      P(2,14)=-0.50*RM*S*TM
      P(3,14)=-0.25*RM*SS
      GO TO 2
   15 H(15)=0.25*RR*SM*TM
      P(1,15)=-0.50*R*SM*TM
      P(2,15)=-0.25*RR*TM
      P(3,15)=-0.25*RR*SM
      GO TO 2
   16 H(16)=0.25*RP*SS*TM
      P(1,16)= 0.25*SS*TM
      P(2,16)=-0.50*RP*S*TM
      P(3,16)=-0.25*RP*SS
      GO TO 2
   17 H(17)=0.25*RP*SP*TT
      P(1,17)= 0.25*SP*TT
      P(2,17)= 0.25*RP*TT
      P(3,17)=-0.50*RP*SP*T
      GO TO 2
   18 H(18)=0.25*RM*SP*TT
      P(1,18)=-0.25*SP*TT
      P(2,18)= 0.25*RM*TT
      P(3,18)=-0.50*RM*SP*T
      GO TO 2
   19 H(19)=0.25*RM*SM*TT
      P(1,19)=-0.25*SM*TT
      P(2,19)=-0.25*RM*TT
      P(3,19)=-0.50*RM*SM*T
      GO TO 2
   20 H(20)=0.25*RP*SM*TT
      P(1,20)= 0.25*SM*TT
      P(2,20)=-0.25*RP*TT
      P(3,20)=-0.50*RP*SM*T
      GO TO 2
   21 H(21)=RR*SS*TT
      P(1,21)=-2.0*R*SS*TT
      P(2,21)=-2.0*S*RR*TT
      P(3,21)=-2.0*T*RR*SS
      GO TO 2
C
C     MODIFY FIRST 8 FUNCTIONS IF 9 OR MORE NODES IN ELEMENT
C
   40 IH=0
   41 IH=IH + 1
      IF (IH.GT.NND9) GO TO 50
      II=IH + 7
      IF (II.EQ.IELX) GO TO 81
   42 IN=NOD9(IH)
      IF (IN.GT.16) GO TO 46
      I1=IN - 8
      I2=IPERM(I1)
      H(I1)=H(I1) - 0.5*H(IN)
      H(I2)=H(I2) - 0.5*H(IN)
      H(IH+8)=H(IN)
      DO 45 J=1,3
      P(J,I1)=P(J,I1) - 0.5*P(J,IN)
      P(J,I2)=P(J,I2) - 0.5*P(J,IN)
   45 P(J,IH+8)=P(J,IN)
      GO TO 41
   46 IF (IN.EQ.21) GO TO 30
      I1=IN - 16
      I2=I1 + 4
      H(I1)=H(I1) - 0.5*H(IN)
      H(I2)=H(I2) - 0.5*H(IN)
      H(IH+8)=H(IN)
      DO 47 J=1,3
      P(J,I1)=P(J,I1) - 0.5*P(J,IN)
      P(J,I2)=P(J,I2) - 0.5*P(J,IN)
   47 P(J,IH+8)=P(J,IN)
      GO TO 41
C
C     MODIFY FIRST 20 FUNCTIONS IF NODE 21 IS PRESENT
C
   30 IH=0
   31 IH=IH + 1
      IN=NOD9(IH)
      IF (IN.EQ.21) GO TO 35
      IF (IN.GT.16) GO TO 33
      I1=IN - 8
      I2=IPERM(I1)
      H(I1)=H(I1) + 0.125*H(21)
      H(I2)=H(I2) + 0.125*H(21)
      DO 32 J=1,3
      P(J,I1)=P(J,I1) + 0.125*P(J,21)
   32 P(J,I2)=P(J,I2) + 0.125*P(J,21)
      GO TO 31
   33 I1=IN - 16
      I2=I1 + 4
      H(I1)=H(I1) + 0.125*H(21)
      H(I2)=H(I2) + 0.125*H(21)
      DO 34 J=1,3
      P(J,I1)=P(J,I1) + 0.125*P(J,21)
   34 P(J,I2)=P(J,I2) + 0.125*P(J,21)
      GO TO 31
   35 DO 36 I=1,8
      H(I)=H(I) - 0.125*H(21)
      DO 36 J=1,3
   36 P(J,I)=P(J,I) - 0.125*P(J,21)
      NN=NND9 + 7
      IF (NN.EQ.8) GO TO 50
      DO 38 I=9,NN
      H(I)=H(I) - 0.25*H(21)
      DO 38 J=1,3
   38 P(J,I)=P(J,I) - 0.25*P(J,21)
      H(NND9+8)=H(21)
      DO 39 J=1,3
   39 P(J,NND9+8)=P(J,21)
C
C     MODIFY APPROPRIATE INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     FOR SPATIAL ISOTROPY FOR SPECIALLY DEGENERATED  20-NODE ELEMENTS
C
   50 IF (IDEGEN.LE.0) GO TO 80
      GO TO (80,60,70),ISOCOR
C
C     CORRECTIONS FOR PRISMS
C
   60 RSF=RR*SS*0.0625
      TPF=TP*0.125
      TMF=TM*0.125
      RSS=R*SS
      RRS=RR*S
      DHT=TP*RSF
      DHB=TM*RSF
      DHTR=-RSS*TPF
      DHTS=-RRS*TPF
      DHTT= RSF
      DHBR=-RSS*TMF
      DHBS=-RRS*TMF
      DHBT=-RSF
C
      H( 2)=H( 2) + DHT
      H( 3)=H( 3) + DHT
      H( 6)=H( 6) + DHB
      H( 7)=H( 7) + DHB
      H(10)=H(10) - DHT - DHT
      H(14)=H(14) - DHB - DHB
C
      P(1,2)=P(1,2) + DHTR
      P(2,2)=P(2,2) + DHTS
      P(3,2)=P(3,2) + DHTT
      P(1,3)=P(1,3) + DHTR
      P(2,3)=P(2,3) + DHTS
      P(3,3)=P(3,3) + DHTT
      P(1,6)=P(1,6) + DHBR
      P(2,6)=P(2,6) + DHBS
      P(3,6)=P(3,6) + DHBT
      P(1,7)=P(1,7) + DHBR
      P(2,7)=P(2,7) + DHBS
      P(3,7)=P(3,7) + DHBT
      P(1,10)=P(1,10) - DHTR - DHTR
      P(2,10)=P(2,10) - DHTS - DHTS
      P(3,10)=P(3,10) - DHTT - DHTT
      P(1,14)=P(1,14) - DHBR - DHBR
      P(2,14)=P(2,14) - DHBS - DHBS
      P(3,14)=P(3,14) - DHBT - DHBT
C
      GO TO 80
C
C     CORRECTIONS FOR TETRAHEDRA
C
   70 RSF=RR*SS*0.0625
      STF=SS*TT*0.0625
      RTF=RR*TT*0.0625
      RTT=R*TT*0.125
      RRT=RR*T*0.125
      DHB=RM*STF
      DHC=SP*RTF
      DHD=TM*RSF
      DHE=SM*RTF
      DHF=RR*STF*0.5
      DHBR=-STF
      DHCR=-SP*RTT
      DHDR=-R*SS*TM*0.125
      DHER=-SM*RTT
      DHFR=-R*STF
      DHBS=-RM*S*TT*0.125
      DHCS= RTF
      DHDS=-S*RR*TM*0.125
      DHES=-RTF
      DHFS=-S*RTF
      DHBT=-RM*SS*T*0.125
      DHCT=-SP*RRT
      DHDT=-RSF
      DHET=-SM*RRT
      DHFT=-T*RSF
      SBDF=DHB+DHD-DHF
      SBDFR=DHBR+DHDR-DHFR
      SBDFS=DHBS+DHDS-DHFS
      SBDFT=DHBT+DHDT-DHFT
C
      H( 5)=H( 5) + DHC + DHE
      H( 6)=H( 6) + DHC + SBDF
      H( 7)=H( 7) + DHE + SBDF
      H(13)=H(13) - DHC - DHC
      H(14)=H(14) - SBDF - SBDF
      H(15)=H(15) - DHE - DHE
C
      P(1,5)=P(1,5) + DHCR + DHER
      P(2,5)=P(2,5) + DHCS + DHES
      P(3,5)=P(3,5) + DHCT + DHET
      P(1,6)=P(1,6) + DHCR + SBDFR
      P(2,6)=P(2,6) + DHCS + SBDFS
      P(3,6)=P(3,6) + DHCT + SBDFT
      P(1,7)=P(1,7) + DHER + SBDFR
      P(2,7)=P(2,7) + DHES + SBDFS
      P(3,7)=P(3,7) + DHET + SBDFT
      P(1,13)=P(1,13) - DHCR - DHCR
      P(2,13)=P(2,13) - DHCS - DHCS
      P(3,13)=P(3,13) - DHCT - DHCT
      P(1,14)=P(1,14) - SBDFR - SBDFR
      P(2,14)=P(2,14) - SBDFS - SBDFS
      P(3,14)=P(3,14) - SBDFT - SBDFT
      P(1,15)=P(1,15) - DHER - DHER
      P(2,15)=P(2,15) - DHES - DHES
      P(3,15)=P(3,15) - DHET - DHET
C
C
C     EVALUATE JACOBIAN MATRIX AT POINT (R,S,T)
C
C
   80 IF (IELX.LT.IELD) RETURN
   81 IF (IINTP.GT.0) GO TO 110
      DO 100 I=1,3
      DO 100 J=1,3
      DUM=0.0
      DO 90 K=1,IELX
   90 DUM=DUM + P(I,K)*XX(J,K)
  100 XJ(I,J)=DUM
C
C
C     COMPUTE DETERMINANT OF JACOBIAN MATRIX AT POINT (R,S,T)
C
C
      DET = XJ(1,1)*XJ(2,2)*XJ(3,3)
     1    + XJ(1,2)*XJ(2,3)*XJ(3,1)
     2    + XJ(1,3)*XJ(2,1)*XJ(3,2)
     3    - XJ(1,3)*XJ(2,2)*XJ(3,1)
     4    - XJ(1,2)*XJ(2,1)*XJ(3,3)
     5    - XJ(1,1)*XJ(2,3)*XJ(3,2)
      IF (DET.GT.1.0D-08) GO TO 110
      WRITE (6,2000) NG,NEL
      STOP
  110 IF (IELX.LT.IELD) GO TO 42
C
C
      RETURN
C
C
C
 2000 FORMAT (////14H *** ERROR ***/18H ELEMENT GROUP NO.,I5/
     1        44H ZERO JACOBIAN DETERMINANT FOR 3/D ELEMENT (,I4,1H))
C
C
      END
C *CDC* *DECK STST3L
C *UNI* )FOR,IS  N.STST3L, R.STST3L
      SUBROUTINE STST3L  (NEL,XX,PROP,DCA,C,MAXES)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      TO GENERATE STRESS-STRAIN LAW FOR                            .
C .        ISOTROPIC OR ORTHOTROPIC LINEAR ELASTIC                    .
C .          THREE-DIMENSIONAL MATERIALS                              .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      DIMENSION XX(3,1),PROP(1),DCA(3,1),C(6,1)
      DIMENSION TEMP(6,6),DUM(6,6),IPRM(3),IPERM(3)
C
      EQUIVALENCE (NPAR(15),MODEL)
      DATA IPRM / 2, 3, 1/, IPERM / 3, 4, 2/
C
C
C
      GO TO (1,100), MODEL
C
C
C     M O D E L  1     LINEAR ELASTIC ISOTROPIC
C
C
    1 YM=PROP(1)
      PV=PROP(2)
C
      C1=1. - 2.*PV
      B1=YM/(1. + PV)
      A1=B1/C1
      D1=1. - PV
C
      DO 9 I=1,6
      DO 9 J=I,6
    9 C(I,J)=0.0
      DO 10 I=1,3
   10 C(I,I)=A1*D1
      DO 11 I=2,3
   11 C(1,I)=A1*PV
      C(2,3)=A1*PV
      DO 12 I=4,6
   12 C(I,I)=B1/2.
      DO 13 I=1,6
      DO 13 J=I,6
   13 C(J,I)=C(I,J)
C
      RETURN
C
C     M O D E L  2     LINEAR ELASTIC ORTHOTROPIC
C
C     FORM THE DIRECT STRAIN PARTITION OF THE STRAIN-STRESS LAW IN
C     MATERIAL COORDINATES (X1,X2,X3)
C
  100 DO 120 I=1,3
  120 TEMP(I,I) = 1.0/PROP(I)
C
      TEMP(1,2) = - PROP(4)*TEMP(2,2)
      TEMP(2,1) =           TEMP(1,2)
      TEMP(1,3) = - PROP(5)*TEMP(3,3)
      TEMP(3,1) =           TEMP(1,3)
      TEMP(2,3) = - PROP(6)*TEMP(3,3)
      TEMP(3,2) =           TEMP(2,3)
C
C     INVERT THE DIRECT STRAIN PARTITION
C
      DO 160 N=1,3
      X=1.0/TEMP(N,N)
      DO 130 J=1,3
  130 TEMP(N,J)= - TEMP(N,J)*X
C
      DO 150 I=1,3
      IF (N.EQ.I) GO TO 150
      DO 140 J=1,3
      IF (N.EQ.J) GO TO 140
      TEMP(I,J)=TEMP(I,J) + TEMP(I,N)*TEMP(N,J)
  140 CONTINUE
  150 TEMP(I,N)=TEMP(I,N)*X
C
      TEMP(N,N)=X
  160 CONTINUE
C
C     FORM THE COMPLETE STRESS STRAIN LAW IN MATERIAL COORDINATES
C
      DO 170 I=1,6
      DO 170 J=1,6
  170 C(I,J)=0.0
      DO 180 I=1,3
      DO 180 J=1,3
  180 C(I,J)=TEMP(I,J)
C
      C(4,4)=PROP(7)
      C(5,5)=PROP(8)
      C(6,6)=PROP(9)
C
C     TRANSFORMATION BETWEEN MATERIAL STRAINS AND GLOBAL STRAINS
      IF (MAXES.LT.1) RETURN
      DO 200 I1=1,3
      I2=IPRM(I1)
      I3=IPERM(I1)
      DO 190 J1=1,3
      J2=IPRM(J1)
      J3=IPERM(J1)
      TEMP(I1   ,J1   ) = DCA(J1,I1)*DCA(J1,I1)
      TEMP(I1+I3,J1   ) = DCA(J1,I1)*DCA(J1,I2)*2.0
      TEMP(I1   ,J1+J3) = DCA(J1,I1)*DCA(J2,I1)
      TEMP(I1+I3,J1+J3) = DCA(J1,I1)*DCA(J2,I2) + DCA(J2,I1)*DCA(J1,I2)
  190 CONTINUE
  200 CONTINUE
C
C     ROTATE THE MATERIAL LAW TO THE GLOBAL SYSTEM
C
      DO 230 I=1,6
      DO 220 J=1,6
      X=0.0
      DO 210 K=1,6
  210 X=X + C(I,K)*TEMP(K,J)
  220 DUM(I,J)=X
  230 CONTINUE
C
      DO 260 I=1,6
      DO 250 J=I,6
      X=0.0
      DO 240 K=1,6
  240 X=X + TEMP(K,I)*DUM(K,J)
      C(I,J)=X
  250 C(J,I) = X
  260 CONTINUE
C
      RETURN
      END
C *CDC* *DECK CROSS2
C *UNI* )FOR,IS N.CROSS2, R.CROSS2
      SUBROUTINE CROSS2 (A,B,C,IERR)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      TO FORM THE VECTOR PRODUCT C=A*B, WHERE C IS NORMALISED TO   .
C .      UNIT LENGTH                                                  .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(3),B(3),C(3)
      X=A(2)*B(3) - A(3)*B(2)
      Y=A(3)*B(1) - A(1)*B(3)
      Z=A(1)*B(2) - A(2)*B(1)
      XLN=DSQRT(X*X + Y*Y + Z*Z)
      IERR=1
      IF (XLN.LE.0.00000001D0) RETURN
      XLN=1.0/XLN
      C(1)=X*XLN
      C(2)=Y*XLN
      C(3)=Z*XLN
      IERR=0
      RETURN
      END
C *CDC* *DECK VECTR2
C *UNI* )FOR,IS N.VECTR2, R.VECTR2
      SUBROUTINE VECTR2 (C,XI,YI,ZI,XJ,YJ,ZJ,IERR)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .   TO FORM A UNIT LENGTH VECTOR V FROM POINT I TO POINT J IN       .
C .      X Y Z  SPACE                                                 .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION C(3)
      X=XJ - XI
      Y=YJ - YI
      Z=ZJ - ZI
      XLN=DSQRT(X*X + Y*Y + Z*Z)
      IERR=1
      IF (XLN.LE.0.00000001D0) RETURN
      XLN=1.0/XLN
      C(1)=X*XLN
      C(2)=Y*XLN
      C(3)=Z*XLN
      IERR=0
      RETURN
      END
C *CDC* *DECK STST3N
C *UNI* )FOR,IS N.STST3N, R.STST3N
      SUBROUTINE STST3N (DISD)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .     S U B R O U T I N E                                           .
C .                                                                   .
C .        TO FIND STRESSES FOR ALL MATERIAL MODELS AND               .
C .           STRESS-STRAIN LAW FOR NONLINEAR MATERIAL MODELS         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION DISD(1),DN(6)
C
      EQUIVALENCE (NPAR(3),INDNL), (NPAR(15),MODEL)
C
C
C     D E F I N I T I O N   O F   S T R A I N
C
C
C     LINEAR STRAIN TERMS
C
      STRAIN(1)=DISD(1)
      STRAIN(2)=DISD(2)
      STRAIN(3)=DISD(3)
      STRAIN(4)=DISD(4) + DISD(6)
      STRAIN(5)=DISD(5) + DISD(8)
      STRAIN(6)=DISD(7) + DISD(9)
      IF (INDNL.LE.1) GO TO 80
C
C     NONLINEAR STRAIN TERMS
C
      DN(1)=0.5*(DISD(1)*DISD(1)+DISD(6)*DISD(6)+DISD(8)*DISD(8))
      DN(2)=0.5*(DISD(4)*DISD(4)+DISD(2)*DISD(2)+DISD(9)*DISD(9))
      DN(3)=0.5*(DISD(5)*DISD(5)+DISD(7)*DISD(7)+DISD(3)*DISD(3))
      DN(4)=    (DISD(1)*DISD(4)+DISD(6)*DISD(2)+DISD(8)*DISD(9))
      DN(5)=    (DISD(1)*DISD(5)+DISD(6)*DISD(7)+DISD(8)*DISD(3))
      DN(6)=    (DISD(4)*DISD(5)+DISD(2)*DISD(7)+DISD(9)*DISD(3))
C
      IF(INDNL.EQ.3) GO TO 29
C
C     CALCULATE GREEN-LAGRANGE STRAINS (TOTAL LAGRANGE FORMULATION)
C
      DO 34 I=1,6
   34 STRAIN(I)=STRAIN(I)+DN(I)
      GO TO 80
C
C     CALCULATE ALMANSI STRAINS (UPDATED LAGRANGIAN FORMULATION AND
C     LINEAR ELASTIC MODEL)
C
   29 IF (MODEL.GT.1) GO TO 80
      DO 44 I=1,6
   44 STRAIN(I)=STRAIN(I)-DN(I)
C
C
C     C A L C U L A T I O N   O F   S T R E S S - S T R A I N
C          M A T R I X   A N D   S T R E S S E S
C
C
   80 GO TO (1,2,3,4,4,6,7,8,8,10,10,12) ,MODEL
C
C
C.... MODEL = 1     L I N E A R   I S O T R O P I C
C
    1 DO 100 I=1,3
      STRESS(I)=D(I,1)*STRAIN(1) + D(I,2)*STRAIN(2) + D(I,3)*STRAIN(3)
  100 STRESS(I+3)=D(4,4)*STRAIN(I+3)
      RETURN
C
C
C.... MODEL = 2     L I N E A R   O R T H O T R O P I C
C
    2 DO 200 I=1,6
      STRESS(I)=0.
      DO 200 J=1,6
  200 STRESS(I)= STRESS(I) + D(I,J)*STRAIN(J)
      RETURN
C
C
C.... MODEL = 3     T H E R M O E L A S T I C
C
C *CDC*     3 CALL OVERLAY (5HADINA,4,1,6HRECALL)
    3 CALL ELT3D3
      RETURN
C
C
C.... MODEL = 4     C U R V E  D E S C R I P T I O N  M O D E L
C.... MODEL = 5     C O N C R E T E  C R A C K I N G  M O D E L
C
C *CDC*     4 CALL OVERLAY (5HADINA,4,2,6HRECALL)
    4 CALL ELT3D4
      RETURN
C
C.... MODEL = 6     (EMPTY)
C
C *CDC*     6 CALL OVERLAY (5HADINA,4,3,6HRECALL)
    6 CALL ELT3D6
      RETURN
C
C.... MODEL = 7     E L A S T I C - P L A S T I C  (DRUCKER-PRAGER)
C
C *CDC*     7 CALL OVERLAY (5HADINA,4,4,6HRECALL)
    7 CALL ELT3D7
      RETURN
C
C.... MODEL = 8,9    E L A S T I C - P L A S T I C (VON MISES)
C
C *CDC*     8 CALL OVERLAY (5HADINA,4,5,6HRECALL)
    8 CALL ELT3D8
      RETURN
C
C
C... MODEL = 10,11    E L A S T I C - P L A S T I C (WITH CREEP)
C
C *CDC*    10 CALL OVERLAY (5HADINA,4,6,6HRECALL)
   10 CALL EL3D10
      RETURN
C
C.... MODEL = 12     (EMPTY)
C
C *CDC*    12 CALL OVERLAY (5HADINA,4,7,6HRECALL)
   12 CALL EL3D12
      RETURN
C
      END
C *CDC* *DECK CGDT3
C *UNI* )FOR,IS  N.CGDT3,R.CGDT3
C
      SUBROUTINE CGDT3 (XYZ,EDIS,ND,NOD9,E1,E2,E3,IDEATH,EDISB)
C
C
C
C     THIS SUBROUTINE CALCULATES THE EIGENVALUES AND EIGENVECTORS
C     OF THE CAUCHY-GREEN DEFORMATION TENSOR. THE EIGENVALUES ARE
C     THEN USED TO OBTAIN THE PRINCIPAL STRETCHES.
C
C     NOTE THAT ALL OF THE EIGENVALUES ARE POSITIVE BECAUSE THE
C     TENSOR IS POSITIVE DEFINITE.
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /PSTCH/ STRCH(3),RDCS(3)
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION CG(3,3),F(3,3),RLMN(3,3),S(3,3),IPRM(3),ICOL(3),
     1          PV(3),DISD(9),XYZ(1),EDISB(1),EDIS(1),NOD9(1),XXX(63),
     2          B(63)
C
      DATA IPRM /2,3,1/
C
C        1. CALCULATE DISPLACEMENT DERIVATIVES
C           (W.R.T. THE INITIAL CONFIGURATION)
C
      DO 500 I=1,ND
  500 XXX(I)=XYZ(I)
      IF (IDEATH.NE.1) GO TO 510
C
      DO 505 I=1,ND
  505 XXX(I)=XXX(I) + EDISB(I)
C
  510 CALL DERIQ3 (NEL,XXX,B,DET,E1,E2,E3,NOD9)
C
      DO 515 I=1,9
  515 DISD(I)=0.0
C
      DO 520 J=3,ND,3
      I=J - 1
      K=J - 2
      DISD(1)=DISD(1) + B(K)*EDIS(K)
      DISD(2)=DISD(2) + B(I)*EDIS(I)
      DISD(3)=DISD(3) + B(J)*EDIS(J)
      DISD(4)=DISD(4) + B(I)*EDIS(K)
      DISD(5)=DISD(5) + B(J)*EDIS(K)
      DISD(6)=DISD(6) + B(K)*EDIS(I)
      DISD(7)=DISD(7) + B(J)*EDIS(I)
      DISD(8)=DISD(8) + B(K)*EDIS(J)
  520 DISD(9)=DISD(9) + B(I)*EDIS(J)
C
C        2. CALCULATE THE DEFORMATION GRADIENT TENSOR
C
      F(1,1)=DISD(1) + 1.0
      F(1,2)=DISD(4)
      F(1,3)=DISD(5)
      F(2,1)=DISD(6)
      F(2,2)=DISD(2) + 1.0
      F(2,3)=DISD(7)
      F(3,1)=DISD(8)
      F(3,2)=DISD(9)
      F(3,3)=DISD(3) + 1.0
C
C        3. FORM THE CAUCHY-GREEN DEFORMATION TENSOR
C
C             CG = F(TRANSPOSED) * F
C
      DO 5 I=1,3
      DO 5 J=1,3
    5 CG(I,J)=0.0
C
      DO 15 I=1,3
      DO 15 J=I,3
      DO 10 M=1,3
   10 CG(I,J)=CG(I,J) + F(M,I)*F(M,J)
   15 CG(J,I)=CG(I,J)
C
C        4. CALCULATE EIGENVALUES AND EIGENVECTORS
C
C           FOR THIS PROBLEM, PV(1) IS ALWAYS THE EIGENVALUE WITH
C           THE LARGEST MAGNITUDE
C
C
C           CALCULATE THE DEVIATORIC TENSOR ASSOCIATED WITH CG
C
      STRAV=(CG(1,1) + CG(2,2) + CG(3,3))/3.0
      DO 18 I=1,3
      DO 18 J=1,3
   18 S(I,J)=CG(I,J)
C
      S(1,1)=S(1,1) - STRAV
      S(2,2)=S(2,2) - STRAV
      S(3,3)=S(3,3) - STRAV
C
C           J2 = SBAR**2 = 1/2 SIJ*SIJ
C
      SBAR=0.
      DO 20 I=1,3
      DO 20 J=1,3
   20 SBAR=SBAR + S(I,J)*S(I,J)
      SBAR=DSQRT(SBAR/2.)
      SBTOL=DABS(STRAV)*1.D-8
      IF (SBAR.LE.SBTOL) SBAR=0.
      IF (SBAR.EQ.0.) GO TO 31
C
C           J3 = 1/3 SIJ*SJK*SKI
C
      RJ3=0.
      DO 30 I=1,3
      DO 30 J=1,3
      DO 30 K=1,3
   30 RJ3=RJ3 + S(I,J)*S(J,K)*S(K,I)
      RJ3=RJ3/3.
C
C           MODIFIED STRESS INVARIANT PHI
C           SIN(3*PHI) = -(3*DSQRT(3)/2)*J3/(SBAR**3)
C
      TEMP=-3.*DSQRT(3.0D0)/2.
      TEMP=TEMP*RJ3/SBAR**3
   31 IF (SBAR.EQ.0.) TEMP=0.
      IF (DABS(TEMP) .LE. 1.0) GO TO 32
      IF (DABS(TEMP) .LE. 1.0001) GO TO 34
      WRITE (6,2000)
      STOP
C
   34 IF (TEMP .LT. (-1.0)) TEMP=-1.0
      IF (TEMP .GT. 1.0) TEMP=1.0
   32 PI=4.D0*DATAN(1.D0)
      TEMPCS=DSQRT(1.D0-TEMP*TEMP)
      PHI=DATAN2(TEMP,TEMPCS)
      IF (PHI.GT.PI) PHI=PHI - 2.D0*PI
      PHI=PHI/3.D0
C
C           CALCULATE THE EIGENVALUES
C
      A1=2.*SBAR/DSQRT(3.0D0)
      PV(1)   =A1*DSIN(PHI + 2.*PI/3.) + STRAV
      PV(2)   =A1*DSIN(PHI) + STRAV
      PV(3)   =A1*DSIN(PHI + 4.*PI/3.) + STRAV
C
C           CALCULATE THE EIGENVECTORS
C
      TOL=0.01
      IND=0
      SPREAD=PV(1) - PV(3)
      ROERR=DABS(PV(1))*0.000001
      IF (PV(1).EQ.0.0) ROERR=DABS(PV(3))*0.000001
      IF (SPREAD.LE.ROERR) GO TO 82
      DIF1=PV(1) - PV(2)
      DIF2=PV(2) - PV(3)
      IF (DIF1.LT.SPREAD*TOL) IND=3
      IF (DIF2.LT.SPREAD*TOL) IND=1
C
      N=3
      I1=IND
      IF (IND.EQ.0) I1=1
      NEIG=2
      DO 78 NX=1,NEIG
C
      DO 35 J1=1,N
      ICOL(J1)=J1
      S(J1,J1)=CG(J1,J1) - PV(I1)
   35 RLMN(J1,I1)=0.
C
C             GAUSSIAN ELIMINATION WITH COMPLETE PIVOTING
C
      DO 65 J=1,N
C
      PIVI=0.
      DO 40 I=J,N
      DO 40 K=J,N
      IF (DABS(PIVI).GT.DABS(S(I,K))) GO TO 40
      IMAX=I
      KMAX=K
      PIVI=S(I,K)
   40 CONTINUE
      IF (KMAX.EQ.J) GO TO 47
C
C             INTERCHANGE OF COLUMNS
C
      ISAVE=ICOL(KMAX)
      ICOL(KMAX)=ICOL(J)
      ICOL(J)=ISAVE
      DO 45 JJ=1,N
      SAVE=S(JJ,KMAX)
      S(JJ,KMAX)=S(JJ,J)
   45 S(JJ,J)=SAVE
C
   47 PIVI=1./PIVI
C
C             INTERCHANGE OF ROWS
C
      DO 50 K=J,N
      IF (IMAX.EQ.J) GO TO 50
      SAVE=S(J,K)
      S(J,K)=S(IMAX,K)
      S(IMAX,K)=SAVE
   50 S(J,K)=S(J,K)*PIVI
C
      IF (J.EQ.(N-1)) GO TO 70
      I2=J + 1
      DO 65 K2=I2,N
      DO 65 J2=I2,N
   65 S(K2,J2)=S(K2,J2) - S(K2,J)*S(J,J2)
C
   70 N1=N - 1
      RLMN(ICOL(N),I1)=1.
      DO 75 J=1,N1
      IA=N
      DO 75 K=1,J
      RLMN(ICOL(N-J),I1)=RLMN(ICOL(N-J),I1)- S(N-J,IA)*RLMN(ICOL(IA),I1)
   75 IA=IA - 1
C
C             SCALE THE EIGENVECTOR TO UNIT MAGNITUDE
C
      RMAX=0.
      DO 74 L1=1,3
   74 IF (DABS(RLMN(L1,I1)).GT.RMAX) RMAX=DABS(RLMN(L1,I1))
      RMAX=RMAX*0.0001
      DO 76 L1=1,3
   76 IF (DABS(RLMN(L1,I1)).LE.RMAX) RLMN(L1,I1)=0.
      XLN=RLMN(1,I1)**2 + RLMN(2,I1)**2 + RLMN(3,I1)**2
      XLN=1.0/DSQRT(XLN)
      IF (RLMN(3,I1).LT.0.) XLN=-XLN
      DO 77 J1=1,3
   77 RLMN(J1,I1)=RLMN(J1,I1)*XLN
C
      IF (I1.EQ.1) GO TO 100
      I1=3
      IF (IND.EQ.3) I1=1
   78 CONTINUE
C
C             CALCULATE THE REMAINING EIGENVECTOR
C
      IND=3
      I2=IPRM(IND)
      I1=IPRM(I2)
      X=RLMN(2,IND)*RLMN(3,I2) - RLMN(3,IND)*RLMN(2,I2)
      Y=RLMN(3,IND)*RLMN(1,I2) - RLMN(1,IND)*RLMN(3,I2)
      Z=RLMN(1,IND)*RLMN(2,I2) - RLMN(2,IND)*RLMN(1,I2)
      XLN=1./DSQRT(X*X + Y*Y + Z*Z)
      IF (Z.LT.0.) XLN=-XLN
      RLMN(1,I1)=X*XLN
      RLMN(2,I1)=Y*XLN
      RLMN(3,I1)=Z*XLN
      GO TO 84
C
   82 DO 83 I1=1,3
      DO 83 J1=1,3
      RLMN(J1,I1)=0.
   83 IF (I1.EQ.J1) RLMN(J1,I1)=1.
   84 CONTINUE
C
C        5. CALCULATE THE PRINCIPAL STRETCHES
C
  100 STRCH(1)=DSQRT(PV(1))
      STRCH(2)=DSQRT(PV(2))
      STRCH(3)=DSQRT(PV(3))
C
      DO 110 I=1,3
  110 RDCS(I)=RLMN(I,1)
C
      RETURN
C
 2000 FORMAT (///,106H   ERROR   UNABLE TO CALCULATE THE EIGENVALUES OF
     1THE CAUCHY-GREEN DEFORMATION TENSOR   (SUBROUTINE CGDT3))
C
      END
C *CDC* *DECK OVL42
C *CDC*       OVERLAY (ADINA,4,2)
C *CDC* *DECK ELT3D4
C *UNI* )FOR,IS  N.ELT3D4, R.ELT3D4
C *CDC*       PROGRAM ELT3D4
      SUBROUTINE ELT3D4
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                  M O D E L    =    4                              .
C .                                                                   .
C .   C U R V E   D E S C R I P T I O N   N O N L I N E A R   M O D E L
C .                                                                   .
C .                  M O D E L    =    5                              .
C .                                                                   .
C .   C O N C R E T E   S T R U C T U R E   M O D E L                 .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
     1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DPR/ ITWO
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT), (NPAR(11),NINTZ), (NPAR(17),NCON)
      EQUIVALENCE (IA(1),A(1)),(NPAR(7),MXNODS)
C
C
C     FOR ADDRESSES N101,N102,N103,.... REFER TO PROGRAM THREDM
C
C
      IDW=22*ITWO
      NPT=NINT*NINT*NINTZ
      MATP=IA(N107 + NEL - 1)
      NM=N111 + (MATP - 1)*NCON*ITWO
      NNOD=N112 + (NEL - 1)*(IDW*NPT + MXNODS) + IDW*NPT
      N6A1=N6A + ITWO
      N6B1=N6B + ITWO
C
C     MATERIAL CONSTANTS ARE STORED IN COMMON CRACK FOR MODEL 4, 5
C
      IF (NPAR(15).EQ.5) GO TO 30
      NM25=NM + 24*ITWO
      ICRACK=IA(NM25)
      GAMMA=DOUBLE (A(NM25 + ITWO))
      STIFAC=DOUBLE (A(NM25 + 2*ITWO))
      SHEFAC=DOUBLE (A(NM25 + 3*ITWO))
      GO TO 50
C
   30 SIGMAT=DOUBLE (A(NM + 3*ITWO))
      SIGMAC=DOUBLE (A(NM + 4*ITWO))
      EPSC  =DOUBLE (A(NM + 5*ITWO))
      SIGMAU=DOUBLE (A(NM + 6*ITWO))
      EPSU  =DOUBLE (A(NM + 7*ITWO))
      BETA=DOUBLE (A(NM + 32*ITWO))
      GAMA=DOUBLE (A(NM + 33*ITWO))
      RKAPA=DOUBLE (A(NM + 34*ITWO))
      ALFA=DOUBLE (A(NM + 35*ITWO))
      STIFAC=DOUBLE (A(NM + 36*ITWO))
      SHEFAC=DOUBLE (A(NM + 37*ITWO))
C
C
C     I N I T I A L I Z E   W A   W O R K I N G   V E C T O R
C
C
   50 NDM=3*MXNODS
      NO=N102 + (NEL - 1)*NDM*ITWO
      ND9DIM=MXNODS - 8
      NOO=N108 + (NEL - 1)*ND9DIM
C
      IF (IND.NE.0) GO TO 100
C
      NN=N112 + (NEL - 1)*IDW*NPT
      IF (NPAR(19).GT.0) NN=NN + (NEL - 1)*MXNODS
      CALL ICMOD3 (NEL,A(NM),A(NN),A(NO),A(NOO),IA(NNOD),A(N6A1))
      GO TO 599
C
C
C     F I N D   S T R E S S - S T R A I N   L A W  A N D  S T R E S S
C
C
  100 IP=6*ITWO
      NMI=NM + IP
      IF (NPAR(15).EQ.5) NMI=NM + 8*ITWO
      NMI2=NMI + IP
      NMI3=NMI2 + IP
      NMI4=NMI3 + IP
      NN=N112 + (NEL - 1)*IDW*NPT + (IPT - 1)*IDW
      IF (NPAR(19).GT.0) NN=NN + (NEL - 1)*MXNODS
      NN6=NN + 6*ITWO
      NN12=NN + 12*ITWO
      NN13=NN12 + ITWO
      NN14=NN13 + ITWO
      NN15=NN14 + ITWO
      NN19=NN15 + 4*ITWO
C
      CALL CMOD3D (NEL,A(NM),A(NMI),A(NMI2),A(NMI3),A(NMI4),A(NN),A(NN6)
     1           ,A(NN12),A(NN13),A(NN14),A(NN15),A(NN19),STRESS,STRAIN,
     2            D,IPT,IA(NNOD),A(N6A1),A(N6B1),A(NO),A(NOO),A(NN))
C
C
  599 CONTINUE
      RETURN
C
      END
C *CDC* *DECK ICMOD3
C *UNI* )FOR,IS  N.ICMOD3, R.ICMOD3
      SUBROUTINE ICMOD3 (NEL,PROP,WA,XYZ,NOD9,NODS,TEMPV1)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),R,S,T
      COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
      DIMENSION PROP(1),WA(22,1),XYZ(1),NOD9(1),NODS(1),TEMPV1(1)
      DIMENSION P(3,21),H(21),XJ(3,3),PGRV(30)
C
      EQUIVALENCE (NPAR(17),NCON),(NPAR(10),NINT),(NPAR(15),MODEL)
     1           ,(NPAR(11),NINTZ),(NPAR(19),ITHERM)
C
C     INITIALIZE WA
C
      NPT=NINT*NINT*NINTZ
      DO 11 J=1,NPT
      DO 10 I=1,22
   10 WA(I,J)=0.
   11 WA(19,J)=100.
      IF (ITHERM.EQ.0) GO TO 18
      II=0
      IELN=8
      IF (NPAR(7).GT.8) IELN=21
      DO 15 K=1,IELN
      IF (NODM(K).EQ.0) GO TO 15
      II=II + 1
      NODS(II)=NODM(K)
   15 CONTINUE
      GO TO 20
   18 IF (MODEL.EQ.5) RETURN
      IF (ICRACK.LT.1) RETURN
C
C
C     FIND PRESSURE AT EACH STRAIN INTERPOLATION POINT IN THE
C     MATERIAL CURVE FOR THIS ELEMENT
C
C
      IPOINT=NCON/4 - 1
      PGRV(1)=0.0
      DO 8 K=2,IPOINT
      DEV=PROP(K) - PROP(K-1)
      BULKK=(PROP(IPOINT+K) + PROP(IPOINT+K-1))/2.0
    8 PGRV(K)=PGRV(K-1) + BULKK*DEV
C
C
C     FIND GROUND PRESSURE AT EACH INTEGRATION POINT OF ELEMENT
C     FIND INITIAL TEMPERATURE AT EACH INTEGRATION POINT FOR MODEL 5
C
C
   20 IPT=0
      IINTP=1
      DO 100 LX=1,NINT
      E1=XG(LX,NINT)
      DO 100 LY=1,NINT
      E2=XG(LY,NINT)
      DO 100 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      IPT=IPT + 1
C
      CALL FUNCT (E1,E2,E3,H,P,NOD9,XJ,DET,XYZ,IINTP)
C
      IF (ITHERM.EQ.0) GO TO 25
      TMPOLD=0.
      DO 23 K=1,IEL
      KK=NODS(K)
   23 TMPOLD=TMPOLD + H(K)*TEMPV1(KK)
      WA(14,IPT)=TMPOLD
      GO TO 100
C
   25 KK=0
      ZDEPTH=0.
      DO 30 K=1,IEL
      KK=KK + 3
   30 ZDEPTH=ZDEPTH + H(K)*XYZ(KK)
      PGRAV=-GAMMA*ZDEPTH
      WA(15,IPT)=PGRAV
C
  100 CONTINUE
C
      IF (ITHERM.GT.0) RETURN
C
C
C     FIND VOLUMETRIC STRAIN FROM GROUND PRESSURE AT INTEGRATION POINTS
C
C
      DO 55 IPT=1,NPT
      PGRAV=WA(15,IPT)
      DO 35 L=2,IPOINT
      J=L
      IF (PGRAV.LT.PGRV(L)) GO TO 40
   35 CONTINUE
      WRITE (6,2002) NEL
      STOP
   40 CONTINUE
      I=J - 1
      DD=PROP(J) - PROP(I)
      C1=PROP(IPOINT+I)
      C2=(PROP(IPOINT+J) - PROP(IPOINT+I))/(2.0*DD)
      IF (C2.GT.1.D-08) GO TO 41
      DEV=(PGRAV - PGRV(I))/C1
      GO TO 50
   41 FAC=C1*C1 + 4.0*C2*(PGRAV - PGRV(I))
      FAC=DSQRT(FAC)
      DEV1=(-C1 + FAC)/(2.0*C2)
      DEV2=(-C1 - FAC)/(2.0*C2)
      I1=0
      I2=0
      IF (DEV1.GE.0.0 .AND. DEV1.LE.DD) I1=1
      IF (DEV2.GE.0.0 .AND. DEV2.LE.DD) I2=1
      IF (I1.NE.I2) GO TO 45
      WRITE(6,2003)
      STOP
   45 IF (I1.EQ.1) DEV=DEV1
      IF (I2.EQ.1) DEV=DEV2
   50 EVGRAV=PROP(I) + DEV
      WA(14,IPT)=EVGRAV
   55 CONTINUE
C
C
      RETURN
C
C
 2002 FORMAT(55H **STOP - GRAVITATIONAL STRAIN TOO LARGE FOR MATERIAL C
     1       ,10HURVE INPUT,12H FOR ELEMENT,I5)
 2003 FORMAT(52H **STOP - ERROR IN PRESSURE-VOLUMETRIC STRAIN CALC.  )
C
      END