C *CDC* *DECK OVL30
C *CDC*       OVERLAY (ADINA,3,0)
C *CDC* *DECK TODMFE
C *UNI* )FOR,IS  N.TODMFE, R.TODMFE
C *CDC*       PROGRAM TODMFE
      SUBROUTINE TODMFE
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   M O D E L S                                                     .
C .                                                                   .
C .   MODEL =  1   LINEAR ISOTROPIC                                   .
C .            2   LINEAR ORTHOTROPIC                                 .
C .            3   LINEAR THERMOELASTIC                               .
C .            4   CURVE DESCRIPTION MODEL                            .
C .            5   CONCRETE STRUCTURE MODEL                           .
C .            6   EMPTY                                              .
C .            7   PLASTIC MODEL (DRUCKER-PRAGER)                     .
C .            8   PLASTIC MODEL (VON MISES - ISOTROPIC HARDENING)    .
C .            9   PLASTIC MODEL (VON MISES - KINEMATIC HARDENING)    .
C .           10   THERMOELASTIC-PLASTIC/CREEP MODEL (ISOTROPIC )     .
C .           11   THERMOELASTIC-PLASTIC/CREEP MODEL (KINEMATIC )     .
C .           12   EMPTY                                              .
C .           13   INCOMPRESSIBLE ELASTIC (MOONEY-RIVLIN)             .
C .           14   PLASTIC MODEL (WANG - HSUAN)                       .
C .                                                                   .
C .   S T O R A G E                                                   .
C .                                                                   .
C .         N101   LM ARRAY (ELEMENT CONNECTIVITY)                    .
C .         N102   YZ ARRAY (ELEMENT COORDINATES)                     .
C .                                                                   .
C .         N103   IELT                                               .
C .         N104   IPST                                               .
C .         N105   BETA                                               .
C .         N106   THICK                                              .
C .         N107   MATP                                               .
C .                                                                   .
C .         N108   DEN                                                .
C .         N109   PROP (MATERIAL CONSTANTS)                          .
C .         N110   WA (WORKING ARRAY)                                 .
C .         N111   NOD5 (MIDSIDE NODES LOCATION ARRAY)                .
C .         N112   ETIMV (ELEMENT EXPIRY TIME ARRAY, IF IDEATH.EQ.1)  .
C .         N113   EDISB (ELEMENT BIRTHTIME NODAL COORDINATES)        .
C .         N114   ITABLE (STRESS OUTPUT LOCATION TABLES)             .
C .         N115   ISKEW (SKEW COORDINATES FLAG)                      .
C .         N116   ISO (SPATIAL ISOTROPY CORRECTION INDICATOR)        .
C .         N117   PDIS  (DISPLACEMENTS AT PREVIOUS STEP)             .
C .                                                                   .
C .         NLAST  LAST ADDRESS REQUIRED                              .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      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 /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 /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),INPAR(20)
C
      EQUIVALENCE (NPAR(2),NUME), (NPAR(3),INDNL), (NPAR(4),IDEATH),
     1            (NPAR(5),ITYP2D), (NPAR(6),NEGSKS), (NPAR(7),MXNODS),
     2            (NPAR(10),NINT), (NPAR(13),NTABLE), (NPAR(15),MODEL),
     3            (NPAR(16),NUMMAT),(NPAR(17),NCON),(NPAR(8),IDEGEN),
     2            (NPAR(19),ITHERM), (NPAR(20),IDW), (NPAR(1),NPAR1)
C
      DATA RECLB1 /8HTYPE-2  /
C
      DATA NMCON / 2, 7,66,28,38, 0, 8, 4, 4,113,113, 0, 2, 21,6*0/,
     1     IDWAS / 0, 0, 0,15,15, 0,10,15,15,33,33, 0, 0, 21,6*0/,
     2     NDWS  /0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0,6*0/
C
C
C
      IULJ=0
      IF (INDNL.EQ.3 .AND. MODEL.EQ.8) IULJ=1
      IF (INDNL.EQ.3 .AND. MODEL.EQ.14) IULJ=1
      IF (IND.NE.0) GO TO 100
      DO 5 I=1,20
    5 INPAR(I)=NPAR(I)
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=15
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=8
      IF (MXNODS.LE.8) GO TO 27
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=7
      IRANGE=8
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   27 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 (ITYP2D.GE.0 .AND. ITYP2D.LT.4) GO TO 35
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=5
      IRANGE=3
      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.12) GO TO 45
      IF (MODEL.EQ.MODMAX) GO TO 45
C
      IDW=IDWAS(MODEL)
      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
C
C     CHECK ON COMPATIBILITY BETWEEN ELEMENTS OF NPAR
C
C        1. COMPATIBILITY OF INDNL AND IDEATH
C
   50 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 OR MODEL=14 ONLY
C
      IF (MODEL.EQ.1 .OR. MODEL.EQ.8) GO TO 56
      IF (MODEL.EQ.14) 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
      IF (MODEL.EQ.14) 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, ITHERM 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
      WRITE (6,2800) (I,I=1,8),INPAR
      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,2910) ITYP2D
      WRITE (6,2920) NEGSKS,MXNODS,IDEGEN
      WRITE (6,2930) NINT,NTABLE
      WRITE (6,2940) MODEL
      WRITE (6,2960) NUMMAT,NCON,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 (LU2) 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
C
  100 NDM=2*MXNODS
      IF (NPAR(5) .EQ. 3) NDM=3*MXNODS
      ND5DIM=MXNODS - 4
      NDW=NDWS(MODEL)
   20 IDWA=IDW*NINT*NINT
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*ITWO
      N107=N106 + NUME*ITWO
      N108=N107 + NUME
C
      N109=N108 + NUMMAT*ITWO
      N110=N109 + NCON*NUMMAT*ITWO
      N111=N110 + IDWA*NUME*ITWO
      IF (NPAR(19).GT.0) N111=N111 + NDW*MXNODS*NUME
      N112=N111 + ND5DIM*NUME
      MM=0
      IF (IDEATH.GT.0) MM=1
      N113=N112 + MM*NUME*ITWO
      MM=0
      IF (IDEATH.EQ.1) MM=1
      N114=N113 + MM*NUME*NDM*ITWO
      N115=N114 + NTABLE*9
      MM=0
      IF (NEGSKS.GT.0) MM=1
      N116=N115 + MM*NUME*MXNODS
      MM=0
      IF (IDEGEN.GT.0) MM=1
      N117=N116 + MM*NUME
      NLAST=N117-1
      IF (IULJ.GT.0) NLAST=N117 + NDM*NUME*ITWO -1
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 (NLAST)
C
  105 IF (IND.GT.3) GO TO 110
      M2=N2
      M3=N3
      M4=N4
      GO TO 120
  110 M2=N5
      M3=N2
      M4=N7
      IF (ICOUNT.LT.3) GO TO 120
      M2=N3
      M3=N6
C
  120 CALL TDFE   (A(N06),A(N1A),A(N1),A(M2),A(M3),A(M4),A(N5),
     1           A(N101),A(N102),A(N103),A(N104),A(N105),A(N106),
     2           A(N107),A(N108),A(N109),A(N110),A(N111),A(N112),
     3           A(N113),A(N114),A(N115),A(N116),A(N117),
     4           NTABLE,NCON,IDWA,NDM,ND5DIM,NDOF,MXNODS)
C
      RETURN
C
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  (2-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,20I4 // )
 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 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 )
 2910 FORMAT (/16H ELEMENT SUBTYPE,12(2H .),16H( NPAR(5) ). . =,I5/,
     1         32H     EQ.0, AXISYMMETRIC ELEMENTS/,
     2         32H     EQ.1, PLANE STRAIN ELEMENTS/,
     3         32H     EQ.2, PLANE STRESS ELEMENTS/,
     4         39H     EQ.3, PLANE STRESS ELEMENTS IN 3/D   )
 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  /,
     9        20H     ANY ONE ELEMENT,10(2H .),16H( NPAR(7) ). . =,I5//,
     8        24H DEGENERATION INDICATOR ,8(2H .),
     7        16H( NPAR(8) ). . =,I5/,
     6        50H     EQ.0, NO DEGENERATION OR NO CORRECTION         /,
     5        50H           FOR SPATIAL ISOTROPY                     /,
     4        50H     EQ.1, SPATIAL ISOTROPY CORRECTIONS APPLIED     /,
     3        50H           TO SPECIALLY DEGENERATED                 /,
     3        50H           8-NODE ELEMENTS                          )
 2930 FORMAT (/40H NUMBER OF INTEGRATION POINTS FOR           /,
     2        40H     ELEMENT STIFFNESS GENERATION. . . .,
     3        16H( NPAR(10)). . =,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)                        /,
     D        50H     EQ.13, INCOMPRESSIBLE ELASTIC (MOONEY-RIVLIN) /,
     E        50H     EQ.14, MODIFIED CAMBRIDGE MODEL               /,
     F        35H     EQ.15, (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//,
     9        32H DIMENSION OF STORAGE ARRAY (WA)/,
     1        26H     PER INTEGRATION POINT,7(2H .),16H( NPAR(20)). . =,
     2        I5//)
C
      END
C *CDC* *DECK TDFE
C *UNI* )FOR,IS  N.TDFE,   R.TDFE
      SUBROUTINE TDFE (RSDCOS,NODSYS,ID,X,Y,Z,HT,LM,YZ,IELT,IPST,BETA,
     1                 THICK,MATP,DEN,PROP,WA,NOD5,ETIMV,EDISB,ITABLE,
     2                 ISKEW,ISO,PDIS,NTABLE,NCON,IDWA,NDM,ND5DIM,
     3                 NDOF,MXNODS)
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 /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 /EM2D/ S(300),XM(24),B(4,16),RE(24),EDIS(24),EDISI(24),
     1              XX(24),NOD(8),NODM(8),NOD5M(4)
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,N,IPS
      COMMON /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
      COMMON /DISDER/ DISD(5)
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /MDFRDM/ IDOF(6)
      COMMON /SKEW/ NSKEWS
      COMMON /XYZLL/  T(3,3),XLOC
      COMMON /GNLSTF/ SGNL(36)
      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
      INTEGER ANODE
C
      DIMENSION ID(NDOF,1),X(1),Y(1),Z(1),HT(1),LM(NDM,1),YZ(NDM,1),
     1          IELT(1), IPST(1), BETA(1), THICK(1), MATP(1),
     2          DEN(1),PROP(NCON,1),WA(IDWA,1),NOD5(ND5DIM,1),ETIMV(1),
     3          ITABLE(NTABLE,9),EDISB(NDM,1),IPTABL(4),ISO(1),
     4          NODSYS(1),RSDCOS(9,1),ISKEW(MXNODS,1),PDIS(NDM,1)
      DIMENSION H(8),P(2,8),XJ(2,2),XYZINT(3,16),XYZ(24)
C
      EQUIVALENCE (NPAR(2),NUME),(NPAR(16),NUMMAT),(NPAR(15),MODEL)
     1           ,(NPAR(10),NINT),(NPAR(1),NPAR1),(NPAR(6),NEGSKS)
     2           ,(NPAR(5),ITYP2D),(NPAR(3),INDNL),(NPAR(4),IDEATH)
     3           ,(NPAR(8),IDEGEN)
C
      DATA ANODE /4HNODE/, RECLB1/8HTYPE-2  /, RECLB2/8HMATERAL2/,
     1     RECLB3/8HOUTABLE2/, RECLB4/8HELEMENT2/, RECLB5/8HNEWSTEP2/,
     2     RECLB6/8HOUTPUT-2/, RECLB7/8HIPOINT-2/
C
C
C
C     .. NOTE .. DURING TIME INTEGRATION :
C                 X = LATEST DISPLACEMENT INCREMENTS
C                 Y = LATEST TOTAL DISPLACEMENTS
C                 Z = VELOCITIES
C
C
      NPT = NINT*NINT
      IDW=IDWA/NPT
      IELCPL=0
      NDPN=2
      IF (NPAR(5) .EQ. 3) NDPN=3
C
      IF (JNPORT.EQ.0) GO TO 3
      IPTABL(1)=1
      IPTABL(2)=NINT
      IPTABL(3)=NINT*(NINT-1) + 1
      IPTABL(4)=NINT*NINT
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     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
      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 MATRT2 (N,DEN(N),PROP(1,N))
C
C     FORM TABLES FOR STRESS OUTPUT
C
      IF (NTABLE.EQ.0) GO TO 90
      IF (IDATWR.LE.1) WRITE (6,2070)
      DO 20 L=1,NTABLE
      READ(5,1002) (ITABLE(L,I),I=1,9)
   20 IF (IDATWR.LE.1) WRITE (6,2060) L,(ITABLE(L,I),I=1,9)
C
C     READ ELEMENT INFORMATION
C
   90 IF (IDATWR.GT.1) GO TO 95
      WRITE (6,2005) (ANODE,I,I=1,8)
      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 (LU2)  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 (LU2)  RECLAB,NTABLE
      IF(NTABLE.GT.0)
     1 WRITE (LU2)  RECLAB,NTABLE,((ITABLE(I,J),I=1,NTABLE),J=1,9)
C
C***  DATA PORTHOLE (END)
C
  100 READ (IREAD,1004) M,IEL,IPS,MTYP,KG,BET,THIC,ETIME,INTLOC,
     1                 (NOD(I),I=1,8)
      IF (N.EQ.1 .AND. M.NE.1) GO TO 101
      IF (IDEATH.EQ.2 .AND. ETIME.EQ.0.) ETIME=100000.
      IF (IEL.EQ.0) IEL=MXNODS
      IF (IEL.LE.MXNODS) GO TO 105
      WRITE(6,2010) M
      STOP
  101 WRITE (6,2015) NSUB,NG
      STOP
  105 IF (KG.EQ.0) KG=1
      IF (ITYP2D.EQ.1) THIC=1.0
      IF (NPAR(5).LE.2) GO TO 120
      IF (NOD(1).NE.NOD(2) .AND. NOD(1).NE.NOD(3) .AND. NOD(2).NE.NOD(3)
     1 ) GO TO 120
      WRITE(6,2012) M
      STOP
  120 IF (M.NE.N) GO TO 200
  121 DO 110 I=1,8
  110 NODM(I)=NOD(I)
      IF (IEL.EQ.4) GO TO 115
      II=0
      DO 114 I=5,8
      NN=NOD(I)
      IF (NN.EQ.0) GO TO 114
      II=II + 1
      NOD5M(II)=I
  114 CONTINUE
  115 IELM=IEL
      THICM=THIC
      IPSM=IPS
      BETM=BET
      MTYPE=MTYP
      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.4) GO TO 131
      JJ=NOD5M(I-4)
      II=NODM(JJ)
  131 I2=I2 + NDPN
      IF (NDPN.EQ.3) YZ(I2-2,N)=X(II)
      YZ(I2-1,N)=Y(II)
      YZ(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
      MATP(N)=MTYPE
      BETA(N)=BETM
      THICK(N)=THICM
      IELT(N)=IELM
      IPST(N)=IPSM
      IF (IELM.EQ.4) GO TO 135
      NN=IELM - 4
      DO 132 I=1,NN
  132 NOD5(I,N)=NOD5M(I)
C
  135 KK=-NDPN
      DO 140 I=1,IELM
      II=NODM(I)
      IF (I.LE.4) GO TO 137
      JJ=NOD5M(I-4)
      II=NODM(JJ)
  137 KK=KK + NDPN
      LL=1
      IF (NDPN.EQ.2 .AND. IDOF(1).EQ.0) LL=2
      DO 140 L=1,NDPN
      LM(KK+L,N)=0
      J=L
      IF (NDPN.EQ.2) J=L+1
      IF (IDOF(J).EQ.1) GO TO 140
      LM(KK+L,N)=ID(LL,II)
      LL=LL + 1
  140 CONTINUE
C
      IF (IDEGEN.LE.0) GO TO 147
      ISOCOR=0
      IF (IELM.NE.8) GO TO 146
      IF (NODM(1).EQ.NODM(4) .AND. NODM(1).EQ.NODM(8)) ISOCOR=1
  146 ISO(N)=ISOCOR
C
  147 IF (NEGSKS.EQ.0) GO TO 148
      DO 145 I=1,IELM
      IF (ISKEW(I,N).NE.0) GO TO 148
  145 CONTINUE
      ISKEW(1,N)=-1
C
  148 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     INITIALIZE PDIS FOR THE UPDATED LAGRANGRIAN JAUMANN FORMULATION
C
  150 IF (IULJ.EQ.0) GO TO 155
      DO 157 I=1,NDM
  157 PDIS(I,N)=0.
C
C     UPDATE COLUMN HEIGHTS AND BANDWIDTH
C
  155 ND=IELM*NDPN
      CALL COLHT(HT,ND,LM(1,N))
C
C     INITIALIZE WORKING STORAGE ARRAY FOR MATERIAL LAW
C
      IELTP=IEL
      IEL=IELM
      NND5=IELM - 4
      CALL INITWA (MODEL)
      IEL=IELTP
C
      IF (IDATWR.LE.1) WRITE (6,2004) N,IELM,IPSM,MTYPE,KKK,BETM,
     1                          THICM,ETIM,INTLM,(NODM(I),I=1,8)
      IF (IJPORT.EQ.0 .AND. INTLM.EQ.0) GO TO 161
C
C     CALCULATE GLOBAL COORDINATES OF INTEGRATION POINTS
C
      ND=NDPN*IELM
      DO 163 L=1,ND
  163 XX(L)=YZ(L,N)
C
      IF (ITYP2D.EQ.3) CALL PLST3D (YZ(1,N),XX,RE,EDIS,S,IELM,0)
C
      KINTP=0
      DO 164 LY=1,NINT
      RINTP=XG(LY,NINT)
      DO 164 LZ=1,NINT
      SINTP=XG(LZ,NINT)
      KINTP=KINTP+1
      IX=0
      YINT=0.
      ZINT=0.
C
      CALL FUNCT2 (RINTP,SINTP,H,P,NOD5M,XJ,DET,XX,N,1)
C
      DO 165 NDPT=1,IELM
      IX=IX+2
      YINT=YINT + H(NDPT)*XX(IX-1)
  165 ZINT=ZINT + H(NDPT)*XX(IX)
C
      IF (ITYP2D.EQ.3) GO TO 167
C
      XYZINT(1,KINTP)=0.
      XYZINT(2,KINTP)=YINT
      XYZINT(3,KINTP)=ZINT
      GO TO 168
C
C     ROTATE COORDINATES TO GLOBAL SYSTEM FOR PLANE STRESS 3D ELEMENTS
C
  167 XYZINT(1,KINTP)=T(1,1)*YINT + T(2,1)*ZINT + T(3,1)*XLOC
      XYZINT(2,KINTP)=T(1,2)*YINT + T(2,2)*ZINT + T(3,2)*XLOC
      XYZINT(3,KINTP)=T(1,3)*YINT + T(2,3)*ZINT + T(3,3)*XLOC
C
C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
C
  168 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 161
      WRITE (LU2) RECLAB,N,IELM,IPSM,MTYPE,BETM,THICM,ETIM,INTLM,
     2             (NODM(I),I=1,8)
      RECLAB = RECLB7
      WRITE (LU2) RECLAB,NPT,((XYZINT(L,I),L=1,3),I=1,NPT)
  161 CONTINUE
C
C***  DATA PORTHOLE (END)
C
      IF (N.EQ.NUME) GO TO 170
C
      N=N+1
      DO 160 I=1,8
      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,24
      RE(I)=0.
      EDISI(I)=0.
  445 EDIS(I)=0.
      DO 448 I=1,36
  448 SGNL(I)=0.
C
      DO 500 N=1,NUME
      MTYPE=MATP(N)
      IEL=IELT(N)
      THIC=THICK(N)
      BET=BETA(N)
      ISOCOR=ISO(N)
      ND=NDPN*IEL
      NND5=IEL - 4
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 500
      DO 460 I=1,ND
  460 XX(I)=YZ(I,N)
      ND=2*IEL
      IF (NDPN.EQ.3) CALL PLST3D (YZ(1,N),XX,RE,EDIS,S,IEL,1)
      DO 480 I=1,300
  480 S(I)=0.
C
      CALL QUADS (ND,B,S,XX,PROP(1,MTYPE),RE,EDIS,EDISI,
     1            IDW,WA(1,N),NOD5(1,N))
      IF (NDPN.EQ.3) CALL PLST3D (YZ(1,N),XX,RE,EDIS,S,IEL,5)
      ND=NDPN*IEL
C
      IF (NEGSKS.EQ.0) GO TO 490
      IF (ISKEW(1,N).LT.0) GO TO 490
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IEL,NDPN)
C
  490 CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  500 CONTINUE
      RETURN
C
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 660 N=1,NUME
      MTYPE=MATP(N)
      THIC=THICK(N)
      IEL=IELT(N)
      ISOCOR=ISO(N)
      ND=NDPN*IEL
      NND5=IEL - 4
      DE=DEN(MTYPE)
      IF (IMASS.EQ.1) GO TO 570
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 660
C
  570 DO 580 I=1,ND
  580 XX(I)=YZ(I,N)
      IF (NDPN.EQ.3) CALL PLST3D (YZ(1,N),XX,RE,EDIS,S,IEL,1)
      CALL QUADM (N,ND,XM,S,XX,NOD5(1,N))
      ND=NDPN*IEL
C
      IF (IMASS.EQ.2) GO TO 640
      CALL ADDMA (A(N4),XM,LM(1,N),ND)
      GO TO 660
C
  640 IF (NEGSKS.EQ.0) GO TO 650
      IF (ISKEW(1,N).LT.0) GO TO 650
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IEL,NDPN)
C
  650 CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
C
  660 CONTINUE
      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
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 DO 710 N=1,NUME
      MTYPE=MATP(N)
      IEL=IELT(N)
      THIC=THICK(N)
      BET=BETA(N)
      ISOCOR=ISO(N)
      ND=NDPN*IEL
      NND5=IEL - 4
      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)=Y(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),IEL,NDPN,1)
      GO TO 720
  712 IF (TIME.GT.ETIM) GO TO 710
C
  720 DO 740 I=1,ND
      RE(I)=0.0
      EDIS(I)=0.
      EDISI(I)=0.0
      XX(I)=YZ(I,N)
      II=LM(I,N)
      IF (II) 736,740,737
  736 II=NEQ - II
  737 EDIS(I)=Y(II)
  740 CONTINUE
C
      IF (NEGSKS.LT.1) GO TO 749
      IF (ISKEW(1,N).LT.0) GO TO 749
      CALL DIRCOS (RSDCOS,EDIS,ISKEW(1,N),IEL,NDPN,1)
C
  749 DO 750 I=1,300
  750 S(I)=0.
      DO 751 I=1,36
  751 SGNL(I)=0.
C
      IF (IDEATH.NE.1) GO TO 752
      DO 754 I=1,ND
      EDIS(I)=EDIS(I) - EDISB(I,N)
  754 XX(I)=XX(I) + EDISB(I,N)
C
  752 IF (IULJ.EQ.0) GO TO 755
      DO 747 L=1,ND
      EDISI(L)=EDIS(L)-PDIS(L,N)
      IF (ICOUNT.LE.2) PDIS(L,N)=EDIS(L)
  747 CONTINUE
C
  755 IF (NDPN.EQ.2) GO TO 756
      DO 758 I=1,ND
  758 XYZ(I)=XX(I)
      IF (INDNL.LE.2) GO TO 759
      DO 757 I=1,ND
  757 XYZ(I)=XX(I)+EDIS(I)
      IF (IULJ.EQ.0) GO TO 759
      CALL PLST3D (XYZ,XX,EDISI,EDIS,S,IEL,2)
      GO TO 756
  759 CALL PLST3D (XYZ,XX,RE,EDIS,S,IEL,3)
  756 ND=2*IEL
      CALL QUADS (ND,B,S,XX,PROP(1,MTYPE),RE,EDIS,EDISI,
     1            IDW,WA(1,N),NOD5(1,N))
      IF (NDPN.EQ.3) CALL PLST3D (XYZ,XX,RE,EDIS,S,IEL,4)
      ND=NDPN*IEL
C
      IF (NEGSKS.LT.1) GO TO 760
      IF (ISKEW(1,N).LT.0) GO TO 760
      CALL DIRCOS (RSDCOS,RE,ISKEW(1,N),IEL,NDPN,2)
C
  760 MADR=N3
      IF (ICOUNT.EQ.3) MADR=N5
      CALL ADDBAN (A(MADR),A(N1),S,RE,LM(1,N),ND,2)
C
      IF (ICOUNT-2) 745,745,710
  745 IF (IREF) 710,730,710
  730 IF (NDPN.EQ.3) CALL PLST3D (XYZ,XX,RE,EDIS,S,IEL,5)
      IF (NEGSKS.EQ.0) GO TO 735
      IF (ISKEW(1,N).LT.0) GO TO 735
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IEL,NDPN)
C
  735 CALL ADDBAN (A(N4),A(N1),S,RE,LM(1,N),ND,1)
C
  710 CONTINUE
      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 (LU2) RECLAB,NG,(NPAR(I),I=1,20),KSTEP,TIME,NEGL,NSUB
C
C***  DATA PORTHOLE (END)
C
  811 IST=4
      IF (ITYP2D.GT.0) IST=3
      STRESS(4) = 0.0
      STRAIN(4) = 0.0
C
  801 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 (ITYP2D.EQ.0) WRITE(6,2022)
      IF (ITYP2D.EQ.1) WRITE(6,2024)
      IF (ITYP2D.EQ.2) WRITE(6,2026)
      IF (ITYP2D.EQ.3) WRITE (6,2027)
      IF (ITYP2D.LE.2) WRITE (6,2028)
      IF (ITYP2D.EQ.3) WRITE (6,2029)
      IF (MODEL .GT. 2) GO TO 802
      IF (INDNL.LE.2 .OR. ITYP2D.LT.2) WRITE (6,2030)
      IF (INDNL.EQ.3 .AND. ITYP2D.GE.2) WRITE (6,2031)
  802 MTYPE=MATP(N)
      IEL   = IELT(N)
      THIC  = THICK(N)
      ISOCOR=ISO(N)
      BET=BETA(N)
      ND=NDPN*IEL
      NND5=IEL - 4
C
      DO 805 I=1,ND
      EDIS(I) = 0.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) = Y(II)
  805 CONTINUE
C
      IF (NEGSKS.LT.1) GO TO 825
      IF (ISKEW(1,N).LT.0) GO TO 825
      CALL DIRCOS (RSDCOS,EDIS,ISKEW(1,N),IEL,NDPN,1)
C
  825 IF (IDEATH.NE.1) GO TO 803
      DO 812 I=1,ND
  812 EDIS(I)=EDIS(I)-EDISB(I,N)
C
  803 IF (IULJ.EQ.0) GO TO 816
      DO 823 I=1,ND
  823 EDISI(I)=EDIS(I) - PDIS(I,N)
C
  816 DO 808 I=1,ND
  808 XX(I)=YZ(I,N)
      IF (IDEATH.NE.1) GO TO 807
      DO 804 I=1,ND
  804 XX(I)=XX(I) + EDISB(I,N)
  807 IF (INDNL.LT.3) GO TO 806
      DO 809 I=1,ND
  809 XX(I)=XX(I) + EDIS(I)
  806 IF (NDPN.LE.2) GO TO 813
      DO 814 I=1,ND
  814 XYZ(I)=XX(I)
      CALL PLST3D (XYZ,XX,RE,EDIS,S,IEL,3)
      IF (IULJ.GT.0) CALL PLST3D (XYZ,XX,RE,EDISI,S,IEL,3)
  813 ND=2*IEL
C
      IF (MODEL.GT.2) GO TO 831
C
C     FORM THE LINEAR STRESS-STRAIN LAW IF APPLICABLE
C
      CALL STSTL (N,XX,PROP(1,MTYPE),D)
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,9
      I=ITABLE(IPS,II)
      IF (I.EQ.0) GO TO 830
C
      CALL DERIQ (N,XX,B,DET,EVAL2(I,1),EVAL2(I,2),X1BAR,NOD5(1,N))
C
      DO 810 J=1,5
  810 DISD(J)=0.0
      DO 815 J=2,ND,2
      JJ=J - 1
      DISD(1)=DISD(1) + B(1,JJ)*EDIS(JJ)
      DISD(2)=DISD(2) + B(2,J)*EDIS(J)
      DISD(3)=DISD(3) + B(3,JJ)*EDIS(JJ)
  815 DISD(4)=DISD(4) + B(3,J)*EDIS(J)
      IF (IST.EQ.3) GO TO 819
      DO 818 J=1,ND,2
  818 DISD(5)=DISD(5) + B(4,J)*EDIS(J)
C
C
  819 IPT=1
      CALL STSTN (XX,PROP(1,MTYPE),DISD,IDW,WA(1,N))
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 CAUCHY
C
C     COMPUTE PRINCIPAL STRESSES AND DIRECTIONS
C
  822 CALL MAXMIN (STRESS,P1,P2,AG)
C
      IF (IPRI.EQ.0) WRITE (6,2040) I,STRESS,P1,P2,AG
C
C
C***  DATA PORTHOLE (START)
C
      RECLAB=RECLB6
      IF (JNPORT.NE.0 .AND. KPLOTE.EQ.0)
     1 WRITE (LU2) RECLAB,I,STRESS,STRAIN
C
C***  DATA PORTHOLE (END)
C
  830 CONTINUE
      GO TO 840
C
C     CALCULATE AND PRINT ELEMENT STRESSES AT INTEGRATION POINTS
C
  831 JPT=1
      RECLAB=RECLB6
      DO 839 LX=1,NINT
      E1=XG(LX,NINT)
      DO 839 LY=1,NINT
      E2=XG(LY,NINT)
      IPT=(LX-1)*NINT + LY
C
      CALL DERIQ (N,XX,B,DET,E1,E2,X1BAR,NOD5(1,N))
C
C     FOR U.L.J. FORMULATION USE STRAIN INCREMENTS
C
      IF (INDNL.EQ.3 .AND. MODEL.GT.1) GO TO 850
      DO 832 J=1,5
  832 DISD(J)=0.0
      DO 833 J=2,ND,2
      JJ=J - 1
      DISD(1)=DISD(1) + B(1,JJ)*EDIS(JJ)
      DISD(2)=DISD(2) + B(2,J)*EDIS(J)
      DISD(3)=DISD(3) + B(3,JJ)*EDIS(JJ)
  833 DISD(4)=DISD(4) + B(3,J)*EDIS(J)
      IF (IST.EQ.3) GO TO 835
      DO 834 J=1,ND,2
  834 DISD(5)=DISD(5) + B(4,J)*EDIS(J)
      GO TO 835
C
  850 DO 851 J=1,5
  851 DISD(J)=0.0
      DO 852 J=2,ND,2
      JJ=J - 1
      DISD(1)=DISD(1) + B(1,JJ)*EDISI(JJ)
      DISD(2)=DISD(2) + B(2,J)*EDISI(J)
      DISD(3)=DISD(3) + B(3,JJ)*EDISI(JJ)
  852 DISD(4)=DISD(4) + B(3,J)*EDISI(J)
      IF (IST.EQ.3) GO TO 835
      DO 853 J=1,ND,2
  853 DISD(5)=DISD(5) + B(4,J)*EDISI(J)
C
  835 IF (IULJ.GT.0 .AND. IPRI.EQ.0)  CALL CGDT2 (YZ(1,N),EDIS,NDPN,
     1    NOD5(1,N),E1,E2,IDEATH,EDISB(1,N),IEL,ITYP2D)
      CALL STSTN (XX,PROP(1,MTYPE),DISD,IDW,WA(1,N))
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 838
      IF (INDNL.NE.2) GO TO 827
C
      CALL CAUCHY
C
C     COMPUTE PRINCIPAL STRESSES AND DIRECTIONS
C
  827 CALL MAXMIN (STRESS,P1,P2,AG)
C
      IF (IPRI.NE.0) GO TO 838
      IF (INDNL.EQ.3 .AND. ITYP2D.GE.2) GO TO 828
      WRITE (6,2040) IPT,STRESS,P1,P2,AG
      GO TO 838
C
  828 EXT=1.0 - 2.0*STRAIN(4)
      XBAR=THIC/DSQRT(EXT)
      WRITE (6,2041) IPT,STRESS,P1,P2,AG,XBAR
C
C
C***  DATA PORTHOLE (START)
C
  838 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 839
      IF (IPT.NE.IPTABL(JPT)) GO TO 839
      WRITE (LU2) RECLAB,IPT,STRESS,STRAIN
      JPT=JPT + 1
C
C***  DATA PORTHOLE (END)
C
  839 CONTINUE
  840 CONTINUE
      RETURN
C
 1000 FORMAT (I5,F10.0)
 1001 FORMAT (8F10.0)
 1002 FORMAT (9I5)
 1004 FORMAT (5I5,5X,3F10.0,I5/8I5)
 2004 FORMAT (/1H ,2I5,3I6,1X,3F10.3,2X,I3,4X,I4,7(4X,I4))
 2005 FORMAT (////4X,20H ELEMENT INFORMATION ,
     1//59H     M   IEL   IPS  MTYP   KG       BET      THIC     ETIME,
     2          2X,6HINTLOC,2X,A4,I1,7(3X,A4,I1))
 2006 FORMAT (56X,11HINTEGRATION,17X,19HGLOBAL  COORDINATES/
     1        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(7)) ***)
 2012 FORMAT (///16H *** FOR ELEMENT,I5,38HNODES 1, 2 AND 3 ARE NOT DIFF
     1ERENT ***    )
 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(2/D CONTINUUM) )
 2022 FORMAT (82X,14H(AXISYMMETRIC), // 1X)
 2024 FORMAT (82X,14H(PLANE STRAIN), // 1X)
 2026 FORMAT (82X,14H(PLANE STRESS), // 1X)
 2027 FORMAT (82X,20H(3-DIM PLANE STRESS), //,1X)
 2028 FORMAT (50H STRESSES ARE MEASURED IN GLOBAL COORDINATE SYSTEM /)
 2029 FORMAT (49H STRESSES ARE MEASURED IN LOCAL COORDINATE SYSTEM /)
 2030 FORMAT (8H ELEMENT,4X,6HOUTPUT,/ 2X,6HNUMBER,2X,8HLOCATION,7X,
     1        8HSTRESSYY,7X,8HSTRESSZZ,7X,8HSTRESSYZ,7X,8HSTRESSXX,
     2        7X,8HSIGMA-P+,7X,8HSIGMA-P-,5X,5HANGLE, / 1X)
 2031 FORMAT (8H ELEMENT,4X,6HOUTPUT/2X,6HNUMBER,2X,8HLOCATION,7X,
     1        8HSTRESSYY,7X,8HSTRESSZZ,7X,8HSTRESSYZ,7X,8HSTRESSXX,
     2        7X,8HSIGMA-P+,7X,8HSIGMA-P-,5X,5HANGLE,5X,9HTHICKNESS/1X)
 2035 FORMAT (I8)
 2040 FORMAT (13X,I5,6E15.4,F10.2)
 2041 FORMAT (13X,I5,6E15.4,F10.2,E14.4)
 2060 FORMAT (10I10)
 2070 FORMAT (//40H S T R E S S   O U T P U T   T A B L E S   //
     1        10H     TABLE,9X,1H1,9X,1H2,9X,1H3,9X,1H4,9X,1H5,9X,1H6,
     2        9X,1H7,9X,1H8,9X,1H9/)
 2400 FORMAT (///16H ELEMENT GROUP =,I2,22H  (2/D ELEMENT / TDFE)/
     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,22H  (2/D ELEMENT / TDFE)/
     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)
C
      END
C *CDC* *DECK INITWA
C *UNI* )FOR,IS  N.INITWA, R.INITWA
      SUBROUTINE INITWA (MODEL)
C
C     INITIALIZES THE WORKING VECTOR WA
C     FOR TWO-DIMENSIONAL MATERIAL MODELS
C
C
      GO TO (1,2,3,4,4,6,7,8,8,10,10,12,13,14,15,15),MODEL
C
C
C.... MODEL = 1    L I N E A R   I S O T R O P I C
C
    1 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 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,3,1,6HRECALL)
    3 CALL ELT2D3
      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,3,2,6HRECALL)
    4 CALL ELT2D4
      RETURN
C
C
C.... MODEL = 6    (EMPTY)
C
C *CDC*   6 CALL OVERLAY (5HADINA,3,3,6HRECALL)
    6 CALL ELT2D6
      RETURN
C
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,3,4,6HRECALL)
    7 CALL ELT2D7
      RETURN
C
C
C.... MODEL = 8    E L A S T I C - P L A S T I C (VON MISES - ISOTROPIC)
C.... MODEL = 9    E L A S T I C - P L A S T I C (VON MISES - KINEMATIC)
C
C *CDC*    8 CALL OVERLAY (5HADINA,3,5,6HRECALL)
    8 CALL ELT2D8
      RETURN
C
C
C.... MODEL = 10   E L A S T I C - P L A S T I C + C R E E P (ISOTROPIC)
C.... MODEL = 11   E L A S T I C - P L A S T I C + C R E E P (KINEMATIC)
C
C *CDC*   10 CALL OVERLAY (5HADINA,3,6,6HRECALL)
   10 CALL EL2D10
      RETURN
C
C
C.... MODEL = 12    (EMPTY)
C
C *CDC*   12 CALL OVERLAY (5HADINA,3,7,6HRECALL)
   12 CALL EL2D12
      RETURN
C
C
C.... MODEL = 13    I N C O M P R E S S I B L E   E L A S T I C
   13 RETURN
C
C.... MODEL = 14    ELASTIC-PLASTIC (MODIFIED CAMBRIDGE)
C
C *CDC*   14 CALL OVERLAY (5HADINA,3,9,6HRECALL)
   14 CALL EL2D14
      RETURN
C
C....MODEL = 15,16  (EMPTY)
C
C *CDC*   15 CALL OVERLAY (5HADINA,3,10,6HRECALL)
   15 CALL EL2D15
      RETURN
C
C
C
      END
C *CDC* *DECK MATRT2
C *UNI* )FOR,IS  N.MATRT2, R.MATRT2
      SUBROUTINE MATRT2 (N,DEN,PROP)
C
C
C     SUBROUTINE TO PRINT OUT MATERIAL PROPERTIES
C     FOR TWO-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)
C
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(17),NCON),(NPAR(20),IDW)
     1           ,(NPAR(16),NUMMAT),(NPAR(19),ITHERM)
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 .OR. MODEL.EQ.14) GO TO 600
      RETURN
C
  500 WRITE(6,2100) N,DEN
C
  600 GO TO (1,2,3,4,5,6,7,8,9,10,10,12,13,14,15,15),MODEL
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
    6 GO TO 50
C
C
C.... MODEL = 7   E L A S T I C   P L A S T I C   ( DRUCKER PRAGER )
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,2110) (PROP(I),I=1,NCON)
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) RETURN
      WRITE (6,3403)
      STOP
C
C
C.... MODEL = 8   E L A S T I C - P L A S T I C  (VON MISES - ISOTROPIC)
C
    8 IF (NCON.GT.4) GO TO 200
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.... MODEL = 9   E L A S T I C - P L A S T I C  (VON MISES - KINEMATIC)
C
    9 IF (NCON.GT.4) GO TO 220
C
      IBUG=0
      IF (PROP(3).GT.0.0) GO TO 154
      IBUG=1
      WRITE (6,3401) NG,N
  154 IF (PROP(4).LT.PROP(1)) GO TO 156
      IBUG=1
      WRITE (6,3402) NG,N
  156 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
  220 IF (IDATWR.GT.1) GO TO 170
      WRITE (6,2111) (PROP(I),I=1,3)
      WRITE (6,2112) PROP(3),PROP(4)
C
  170 IBUG=0
      IF (PROP(3).GT.0.0) GO TO 171
      IBUG=1
      WRITE (6,3401) NG,N
  171 ICP=4
      DO 175 I=1,6
      IF (PROP(ICP).EQ.0.0) GO TO 175
      ICP2=ICP+2
      IF (PROP(ICP).NE.PROP(ICP2)) GO TO 175
      IBUG=1
      WRITE (6,3404) NG,N,ICP,ICP2
  175 ICP=ICP+2
C
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) GO TO 177
      WRITE (6,3403)
      STOP
C
  177 DO 230 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
  230 CONTINUE
      RETURN
C
C
C.... MODEL = 10,11   E L A S T I C   P L A S T I C ,   C R E E P
C
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(K),K=105,113)
C
  120 IF(PROP(110).LT.6.0) WRITE(6,2305)
      IF(MODEX.EQ.0.OR.IBUG.EQ.0) RETURN
      STOP
C
C
C.... MODEL = 12   EMPTY
C
   12 GO TO 50
C
C.... MODEL = 13    I N C O M P R E S S I B L E   N O N L I N E A R
C                    E L A S T I C    ( MOONEY-RIVLIN MATERIAL IN STATE
C                      OF PLANE STRESS )
C
   13 WRITE(6,2109) PROP(1),PROP(2)
      RETURN
C
C.... MODEL = 14   ELASTIC - PLASTIC (MODIFIED CAMBRIDGE)
C
C
   14 IBUG=0
      IF (PROP(9).LT.0.0 .AND. PROP(11).LT.0.0) GO TO 114
      IBUG=1
      WRITE (6,3405) NG,N
  114 IF(IDATWR.LE.1) GO TO 50
      IF(MODEX.EQ.0 .OR. IBUG.EQ.0) RETURN
      WRITE(6,3403)
      STOP
C
C
   15 GO TO 50
C
C
   50 WRITE(6,2500) (I,PROP(I), I=1,NCON)
      RETURN
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///)
 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)
 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 ,4X,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///)
 2109 FORMAT (1H ,4X,29HC1 ...........( PROP(1) ).. =, E14.6/,
     1        1H ,4X,29HC2 ...........( PROP(2) ).. =, E14.6///)
 2110 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 MODEL WITH NO TENSION          /,
     3        48H    EQ.2, SOIL MODEL, NO TENSION, STRESS RELEASE   /,
     5        31H MATERIAL DENSITY           = (,E13.4,1H),/
     1        31H STIFFNESS REDUCTION FACTOR = (,E13.4,1H),/
     2        31H SHEAR REDUCTION FACTOR     = (,E13.4,1H),1X)
 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)
 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,
     1        ///)
 3003 FORMAT (//,43H    ERROR   TEMPERATURE POINTS OUT OF ORDER,///)
 3400 FORMAT (//50H INPUT ERROR DETECTED IN (MATRT2/2D 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 (MATRT2/2D 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 (MATRT2/2D 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 (MATRT2/2D 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 //)
 3405 FORMAT (//50H INPUT ERROR DETECTED IN (MATRT2/2D SOLID)         //
     1          19H ELEMENT GROUP NO = ,I5/
     2          27H MATERIAL PROPERTY SET NO = ,I5/
     3          50H PARAMETER PROP(9) AND PROP(11) SHOULD BE LESS      /
     4          20H THAN ZERO                  //)
C
C
      END
C *CDC* *DECK PLST3D
C *UNI* )FOR,IS N.PLST3D,R.PLST3D
      SUBROUTINE PLST3D (XYZ,XX,RE,EDIS,S,IEL,IFLAG)
C
C     IFLAG.LE.1   CALCULATE LOCAL NODAL POINT COORDINATES  XX
C     IFLAG.EQ.2   CALCULATE LOCAL XX, EDIS AND RE
C     IFLAG.EQ.3   CALCULATE LOCAL NODAL COORDINATES XX AND
C                  DISPLACEMENT  EDIS
C     IFLAG.EQ.4   CALCULATE GLOBAL FORCE VECTOR RE AT NODAL POINTS
C     IFLAG.EQ.5   CALCULATE GLOBAL STIFFNESS  S
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /VAR/   NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,IREF,
     1               IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
      COMMON /XYZLL/  T(3,3),XLOC
      COMMON /GNLSTF/ SGNL(36)
C
      DIMENSION XYZ(1),XX(1),RE(1),EDIS(1),S(1),DUM(300),ILSK(8),TMA(9)
C
C     CALCULATE TRANSFORMATION MATRIX  T
C
      TOL=1.D-9
      X21=XYZ(4)-XYZ(1)
      Y21=XYZ(5)-XYZ(2)
      Z21=XYZ(6)-XYZ(3)
      X31=XYZ(7)-XYZ(1)
      Y31=XYZ(8)-XYZ(2)
      Z31=XYZ(9)-XYZ(3)
C
      XY=X21*Y31 - Y21*X31
      YZ=Y21*Z31 - Z21*Y31
      ZX=Z21*X31 - X21*Z31
      SX=DSQRT(X21*X21 + Y21*Y21 + Z21*Z21)
      SZ=DSQRT(YZ*YZ + ZX*ZX + XY*XY)
      SY=SX*SZ
C
      IF (SX.LT.TOL) GO TO 300
      IF (SZ.LT.TOL) GO TO 300
C
      T(1,1)= X21/SX
      T(1,2)= Y21/SX
      T(1,3)= Z21/SX
      T(2,1)=(Z21*ZX - Y21*XY)/SY
      T(2,2)=(X21*XY - Z21*YZ)/SY
      T(2,3)=(Y21*YZ - X21*ZX)/SY
      T(3,1)= YZ/SZ
      T(3,2)= ZX/SZ
      T(3,3)= XY/SZ
C
      IF (IFLAG .GE. 4) GO TO 70
C
C     TRANSFORM COORDINATES,FORCES,DISPLACEMENTS FROM GLOBAL TO
C     LOCAL PLANE
C
      XLOC=0.
      IF (IFLAG.GT.0) GO TO 45
      DO 40 I=1,3
   40 XLOC=XLOC + T(3,I)*XYZ(I)
C
   45 DO 50 I=1,IEL
      I2=2*I
      I3=3*I
      XX(I2-1)=T(1,1)*XYZ(I3-2) + T(1,2)*XYZ(I3-1) + T(1,3)*XYZ(I3)
      XX(I2  )=T(2,1)*XYZ(I3-2) + T(2,2)*XYZ(I3-1) + T(2,3)*XYZ(I3)
      IF (IFLAG.LE.1) GO TO 50
      TEMPA=T(1,1)*EDIS(I3-2) + T(1,2)*EDIS(I3-1) + T(1,3)*EDIS(I3)
      EDIS(I2  )=T(2,1)*EDIS(I3-2) + T(2,2)*EDIS(I3-1) + T(2,3)*EDIS(I3)
      EDIS(I2-1)=TEMPA
      IF (IFLAG .EQ. 3) GO TO 50
      TEMPA=T(1,1)*RE(I3-2) + T(1,2)*RE(I3-1) + T(1,3)*RE(I3)
      RE(I2  )=T(2,1)*RE(I3-2) + T(2,2)*RE(I3-1) + T(2,3)*RE(I3)
      RE(I2-1)=TEMPA
   50 CONTINUE
      RETURN
C
C     TRANSFORM EDIS,RE AND/OR STIFFNESS FROM LOCAL TO GLOBAL PLANE
C
   70 NDOFL=2*IEL
      NDOFG=3*IEL
      IF (IFLAG .EQ. 5) GO TO 100
      DO 75 I=1,NDOFL
   75 DUM(I)=RE(I)
      DO 80 I=1,IEL
      I2=2*I
      I3=3*I
      RE(I3-2)=T(1,1)*DUM(I2-1) + T(2,1)*DUM(I2)
      RE(I3-1)=T(1,2)*DUM(I2-1) + T(2,2)*DUM(I2)
      RE(I3  )=T(1,3)*DUM(I2-1) + T(2,3)*DUM(I2)
   80 CONTINUE
C
      DO 85 I=1,NDOFL
   85 DUM(I)=EDIS(I)
      DO 90 I=1,IEL
      I2=2*I
      I3=3*I
      EDIS(I3-2)=T(1,1)*DUM(I2-1) + T(2,1)*DUM(I2)
      EDIS(I3-1)=T(1,2)*DUM(I2-1) + T(2,2)*DUM(I2)
      EDIS(I3  )=T(1,3)*DUM(I2-1) + T(2,3)*DUM(I2)
   90 CONTINUE
C
      RETURN
C
C     ASSEMBLE ELEMENT STIFFNESS WITH 3 D.O.F. PER NODE
C
  100 NDIM3=NDOFG*(NDOFG+1)/2
      DO 102 I=1,NDIM3
  102 DUM(I)=0.
      I=1
      KG1=1
      KG2=1
      KG3=2
      DO 120 L=1,IEL
      IP=I+1
      I1=I-1
      J =(I1+I1)/3 + 1
      J1=J-1
      ND2=NDOFL*J1 - (J1-1)*J1/2 + 1
      ND3=NDOFG*I1 - (I1-1)*I1/2 + 1
      NDG=NDOFG*IP - IP*I/2 + 1
      LD2=0
      LD3=0
      LDG=0
      DO 130 K=L,IEL
      DUM(ND3+LD3)=S(ND2+LD2) + SGNL(KG1)
      DUM(ND3+LD3+1)=S(ND2+LD2+1)
      DUM(NDG+LDG)=SGNL(KG1)
      KG1=KG1+1
      LDG=LDG+3
      LD2=LD2+2
  130 LD3=LD3+3
      L1=L-1
      LP=L+1
      MD3=ND3 + NDOFG - 3*L1
      MD2=ND2 + NDOFL - L1 - L1
      DUM(MD3)=S(MD2) + SGNL(KG2)
      IF (LP.GT.IEL) GO TO 120
      KG2=KG2 + IEL - L1
      LD2=1
      LD3=2
      DO 140 K=LP,IEL
      DUM(MD3+LD3)=S(MD2+LD2)
      DUM(MD3+LD3+1)=S(MD2+LD2+1) + SGNL(KG3)
      KG3=KG3+1
      LD2=LD2+2
  140 LD3=LD3+3
      KG3=KG3+1
  120 I=I+3
C
C     CALCULATE GLOBAL STIFFNESS VIA TRANSFORMATION
C
      IR=0
      DO 160 K=1,IEL
  160 ILSK(K)=1
      DO 180 I=1,3
      DO 182 J=1,3
  182 TMA(J+IR)=T(J,I)
  180 IR=IR+3
C
      CALL ATKA (TMA,DUM,ILSK,IEL,3)
C
      DO 190 I=1,NDIM3
  190 S(I)=DUM(I)
C
C
      RETURN
C
  300 WRITE (6,2000) NG,NEL
      STOP
C
 2000 FORMAT (////14H *** ERROR ***/18H ELEMENT GROUP NO.,I5/
     1            50H ZERO OR NEGATIVE JACOBIAN DETERMINANT FOR ELEMNT ,
     2            I5////13H *** STOP ***  )
C
C
      END
C *CDC* *DECK QUADS
C *UNI* )FOR,IS  N.QUADS,  R.QUADS
      SUBROUTINE QUADS (ND,B,S,YZ,PROP,RE,EDIS,EDISI,IDW,WA,NOD5)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C        ISOPARAMETRIC FORMULATION OF QUADRILATERAL ELEMENT STIFFNESS
C        FOR AXISYMMETRIC GEOMETRY (PLANE STRESS AND PLANE STRAIN
C                                                       INCLUDED)
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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
      COMMON /DISDER/ DISD(5)
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /GNLSTF/ SGNL(36)
C
      DIMENSION B(4,1),S(1),YZ(1),RE(1),EDIS(1),PROP(1),WA(1),NOD5(1)
      DIMENSION DB(4),XX(16),BS(4,16),DI(4,4),EDISI(1)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(5),ITYP2D),(NPAR(3),INDNL)
      EQUIVALENCE (NPAR(15),MODEL)
C
C
      NPT=NINT*NINT
      IST=4
      IF (ITYP2D.NE.0) IST=3
      KST=IST-1
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
      CALL STSTL (NEL,YZ,PROP,D)
C
      DO 10 LX=1,NINT
      E1=XG(LX,NINT)
      DO 10 LY=1,NINT
      E2=XG(LY,NINT)
      WT=WGT(LX,NINT)*WGT(LY,NINT)
C
C     EVALUATE DERIVATIVE OPERATOR AND THE JACOBIAN DETERMINANT
C
      CALL DERIQ (NEL,YZ,B,DET,E1,E2,XBAR,NOD5)
C
C     ADD CONTRIBUTION TO ELEMENT STIFFNESS
C
      IF (IST.EQ.3) XBAR=THIC
      FAC=WT*XBAR*DET
C
      KL=1
      DO 50 J=1,ND,2
      DO 52 K=1,3
      DB(K)=D(K,1)*B(1,J) + D(K,3)*B(3,J)
   52 DB(K)=DB(K)*FAC
      DO 51 I=J,ND,2
      S(KL)=S(KL) + B(1,I)*DB(1) + B(3,I)*DB(3)
      KL=KL + 1
      S(KL)=S(KL) + B(2,I+1)*DB(2) + B(3,I+1)*DB(3)
   51 KL=KL + 1
   50 KL=KL + ND - J
C
      KL=ND + 1
      DO 54 J=2,ND,2
      DO 56 K=1,3
      DB(K)=D(K,2)*B(2,J) + D(K,3)*B(3,J)
   56 DB(K)=DB(K)*FAC
      KS=KL
      DO 55 I=J,ND,2
      S(KS)=S(KS) + B(2,I)*DB(2) + B(3,I)*DB(3)
   55 KS=KS + 2
      IF (J-ND) 57,54,54
   57 K=J + 1
      KS=KL + 1
      DO 58 II=K,ND,2
      S(KS)=S(KS) + B(1,II)*DB(1) + B(3,II)*DB(3)
   58 KS=KS + 2
   54 KL=KL + 2*ND - 2*J + 1
C
      IF (IST.EQ.3) GO TO 10
      KL=1
      DO 60 J=1,ND,2
      DB(1)=D(1,4)*B(4,J)*FAC
      DB(2)=D(2,4)*B(4,J)*FAC
      DB(3)=D(3,4)*B(4,J)*FAC
      DB(4)=D(4,1)*B(1,J) + D(4,3)*B(3,J) + D(4,4)*B(4,J)
      DB(4)=DB(4)*FAC
      DO 61 I=J,ND,2
      S(KL)=S(KL) + B(1,I)*DB(1) + B(3,I)*DB(3) + B(4,I)*DB(4)
      KL=KL + 1
      S(KL)=S(KL) + B(2,I+1)*DB(2) + B(3,I+1)*DB(3)
   61 KL=KL + 1
   60 KL=KL + ND - J
      KL=ND + 1
      DO 59 J=2,ND,2
      DB(4)=D(4,2)*B(2,J) + D(4,3)*B(3,J)
      DB(4)=DB(4)*FAC
      DO 62 I=J,ND
      S(KL)=S(KL) + B(4,I)*DB(4)
   62 KL=KL + 1
   59 KL=KL + ND - J
C
   10 CONTINUE
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
C     UPDATE ELEMENT COORDINATES
C
  100 IF (INDNL.LE.2) GO TO 122
      IF (ITYP2D.LE.2) GO TO 118
      DO 116 I=1,ND
  116 XX(I)=YZ(I)
      GO TO 122
  118 DO 120 J=1,ND
  120 XX(J) = YZ(J) + EDIS(J)
C
C     EVALUATE STRESS STRAIN LAW IN CASE MATERIAL VARIABLES ARE
C     CONSTANT , I.E. , FOR MODEL.EQ.1  AND MODEL.EQ.2
C
  122 IF (MODEL.GT.2) GO TO 125
      IF (INDNL.LE.2) GO TO 124
      CALL STSTL (NEL,XX,PROP,D)
      GO TO 125
  124 CALL STSTL (NEL,YZ,PROP,D)
C
C
C     INTEGRATE STIFFNESS MATRIX AND ELEMENT NODAL FORCE EXPRESSION
C
C
  125 DO 300 LX=1,NINT
      E1=XG(LX,NINT)
      DO 300 LY=1,NINT
      E2=XG(LY,NINT)
      WT=WGT(LX,NINT)*WGT(LY,NINT)
      IPT=(LX-1)*NINT + LY
      IF (INDNL.EQ.3) GO TO 200
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 THE DERIVATIVE OPERATOR B
C
      CALL DERIQ (NEL,YZ,B,DET,E1,E2,XBAR,NOD5)
C
C     CALCULATE DISPLACEMENT DERIVATIVES
C
      DO 130 I=1,5
  130 DISD(I)=0.0
      DO 140 J=2,ND,2
      I=J - 1
      DISD(1)=DISD(1) + B(1,I)*EDIS(I)
      DISD(2)=DISD(2) + B(2,J)*EDIS(J)
      DISD(3)=DISD(3) + B(3,I)*EDIS(I)
  140 DISD(4)=DISD(4) + B(3,J)*EDIS(J)
      IF (IST.EQ.3) GO TO 160
      DO 150 I=1,ND,2
  150 DISD(5)=DISD(5) + B(4,I)*EDIS(I)
C
C     EVALUATE STRESS-STRAIN LAW AND CURRENT STRESSES
C
  160 CALL STSTN (YZ,PROP,DISD,IDW,WA)
C
      IF (INDNL.LE.1) GO TO 221
C
C     EVALUATE DERIVATIVE OPERATOR INCLUDING THE INITIAL
C     DISPLACEMENT EFFECTS
C
      DO 164 J=2,ND,2
      I=J - 1
      BS(1,I)=B(1,I) + B(1,I)*DISD(1)
      BS(1,J)=B(1,I)*DISD(4)
      BS(2,I)=B(2,J)*DISD(3)
      BS(2,J)=B(2,J) + B(2,J)*DISD(2)
      BS(3,I)=B(3,I) + B(3,I)*DISD(1) + B(3,J)*DISD(3)
  164 BS(3,J)=B(3,J) + B(3,I)*DISD(4) + B(3,J)*DISD(2)
      IF (IST.EQ.3) GO TO 167
      DO 166 I=1,ND,2
      J=I + 1
      BS(4,J)=0.0
  166 BS(4,I)=B(4,I) + B(4,I)*DISD(5)
C
C     ADD STRESS CONTRIBUTION TO ELEMENT FORCE VECTOR
C
  167 IF (IST.EQ.3) XBAR=THIC
      FAC=WT*XBAR*DET
      TAU11=STRESS(1)*FAC
      TAU22=STRESS(2)*FAC
      TAU12=STRESS(3)*FAC
      TAU33=STRESS(4)*FAC
      DO 170 I=1,ND
  170 RE(I)=RE(I) + BS(1,I)*TAU11 + BS(2,I)*TAU22 + BS(3,I)*TAU12
      IF (IST.EQ.3) GO TO 176
      DO 174 J=1,ND,2
  174 RE(J)=RE(J) + BS(4,J)*TAU33
C
  176 IF (ICOUNT - 2) 178,178,300
  178 IF (IREF) 300,179,300
C
C     ADD LINEAR CONTRIBUTION TO ELEMENT STIFFNESS MATRIX
C
  179 DO 183 I=1,IST
      DO 183 J=I,IST
      DI(I,J)=D(I,J)*FAC
  183 DI(J,I)=DI(I,J)
      KL=0
      DO 180 J=1,ND
      DO 182 K=1,IST
      DB(K)=0.
      DO 184 L=1,IST
  184 DB(K)=DB(K) + DI(K,L)*BS(L,J)
  182 CONTINUE
C
      DO 180 I=J,ND
      KL=KL + 1
      DUM=0.
      DO 186 K=1,IST
  186 DUM=DUM + BS(K,I)*DB(K)
  180 S(KL)=S(KL) + DUM
C
      GO TO 365
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 THE DERIVATIVE OPERATOR B
C
  200 CALL DERIQ (NEL,XX,B,DET,E1,E2,XBAR,NOD5)
C
C     CALCULATE DISPLACEMENT DERIVATIVES
C
C        1. FOR MODEL=1, USE ALMANSI STRAINS
C
      IF (MODEL.GT.1) GO TO 215
      DO 210 I=1,5
  210 DISD(I)=0.
      DO 212 J=2,ND,2
      I=J - 1
      DISD(1)=DISD(1) + B(1,I)*EDIS(I)
      DISD(2)=DISD(2) + B(2,J)*EDIS(J)
      DISD(3)=DISD(3) + B(3,I)*EDIS(I)
  212 DISD(4)=DISD(4) + B(3,J)*EDIS(J)
      IF (IST.EQ.3) GO TO 216
      DO 214 I=1,ND,2
  214 DISD(5)=DISD(5) + B(4,I)*EDIS(I)
      GO TO 216
C
C        2. FOR PLASTICITY AND CREEP MODELS (U.L.J. FORMULATIONS)
C          USE STRAIN INCREMENTS
C
  215 DO 217 I=1,5
  217 DISD(I)=0.0
      DO 218 J=2,ND,2
      I=J - 1
      DISD(1)=DISD(1) + B(1,I)*EDISI(I)
      DISD(2)=DISD(2) + B(2,J)*EDISI(J)
      DISD(3)=DISD(3) + B(3,I)*EDISI(I)
  218 DISD(4)=DISD(4) + B(3,J)*EDISI(J)
      IF (IST.EQ.3) GO TO 216
      DO 219 I=1,ND,2
  219 DISD(5)=DISD(5) + B(4,I)*EDISI(I)
C
C     EVALUATE STRESS-STRAIN LAW AND CURRENT STRESSES
C
  216 CALL STSTN (XX,PROP,DISD,IDW,WA)
C
  221 IF (ITYP2D.EQ.0) GO TO 222
      XBAR=THIC
      IF (INDNL.LE.1 .OR. ITYP2D.EQ.1) GO TO 222
      IF (MODEL.GT.1) GO TO 223
      EXT=1.0 - 2.0*STRAIN(4)
      XBAR=XBAR/DSQRT(EXT)
      GO TO 222
C
  223 XBAR=THIC*DEXP(STRAIN(4))
C
  222 FAC=WT*XBAR*DET
C
C     ADD STRESS CONTRIBUTION TO ELEMENT FORCE VECTOR
C
      TAU11=STRESS(1)*FAC
      TAU22=STRESS(2)*FAC
      TAU12=STRESS(3)*FAC
      TAU33=STRESS(4)*FAC
      DO 340 J=2,ND,2
      I=J - 1
      RE(I)=RE(I) + B(1,I)*TAU11 + B(3,I)*TAU12
  340 RE(J)=RE(J) + B(2,J)*TAU22 + B(3,J)*TAU12
      IF (IST.EQ.3) GO TO 350
      DO 345 J=1,ND,2
  345 RE(J)=RE(J) + B(4,J)*TAU33
C
  350 IF (ICOUNT-2) 220,220,300
  220 IF (IREF) 300,230,300
C
C     ADD LINEAR CONTRIBUTION TO STIFFNESS MATRIX
C
  230 DO 232 I=1,IST
      DO 232 J=I,IST
      DI(I,J)=D(I,J)*FAC
  232 DI(J,I)=DI(I,J)
      KL=1
      DO 250 J=1,ND,2
      DO 252 K=1,3
  252 DB(K)=DI(K,1)*B(1,J) + DI(K,3)*B(3,J)
      DO 251 I=J,ND,2
      S(KL)=S(KL) + B(1,I)*DB(1) + B(3,I)*DB(3)
      KL=KL + 1
      S(KL)=S(KL) + B(2,I+1)*DB(2) + B(3,I+1)*DB(3)
  251 KL=KL + 1
  250 KL=KL + ND - J
      KL=ND + 1
C
      DO 254 J=2,ND,2
      DO 256 K=1,3
  256 DB(K)=DI(K,2)*B(2,J) + DI(K,3)*B(3,J)
      KS=KL
      DO 255 I=J,ND,2
      S(KS)=S(KS) + B(2,I)*DB(2) + B(3,I)*DB(3)
  255 KS=KS + 2
      IF (J-ND) 257,254,254
  257 K=J + 1
      KS=KL + 1
      DO 258 II=K,ND,2
      S(KS)=S(KS) + B(1,II)*DB(1) + B(3,II)*DB(3)
  258 KS=KS + 2
  254 KL=KL + 2*ND - 2*J + 1
C
      IF (IST.EQ.3) GO TO 365
      KL=1
      DO 260 J=1,ND,2
      DB(1)=DI(1,4)*B(4,J)
      DB(2)=DI(2,4)*B(4,J)
      DB(3)=DI(3,4)*B(4,J)
      DB(4)=DI(4,1)*B(1,J) + DI(4,3)*B(3,J) + DI(4,4)*B(4,J)
      DO 261 I=J,ND,2
      S(KL)=S(KL) + B(1,I)*DB(1) + B(3,I)*DB(3) + B(4,I)*DB(4)
      KL=KL + 1
      S(KL)=S(KL) + B(2,I+1)*DB(2) + B(3,I+1)*DB(3)
  261 KL=KL + 1
  260 KL=KL + ND - J
      KL=ND + 1
      DO 259 J=2,ND,2
      DB(4)=DI(4,2)*B(2,J) + DI(4,3)*B(3,J)
      DO 262 I=J,ND
      S(KL)=S(KL) + B(4,I)*DB(4)
  262 KL=KL + 1
  259 KL=KL + ND - J
C
C
C     T O T A L   A N D   U P D A T E D   L A G R A N G I A N
C                                    F O R M U L A T I O N
C
C
C     ADD NONLINEAR CONTRIBUTION TO STIFFNESS MATRIX
C
  365 IF (INDNL.EQ.1) GO TO 300
      IF (ITYP2D.EQ.3) GO TO 500
C
      KL=1
      DO 400 J=1,ND,2
      DB1=TAU11*B(1,J) + TAU12*B(3,J)
      DB2=TAU12*B(1,J) + TAU22*B(3,J)
C
      KS=KL
      DO 401 I=J,ND,2
      KSS=KS + ND - J + 1
      DUM=B(1,I)*DB1 + B(3,I)*DB2
      S(KS)=S(KS) + DUM
      S(KSS)=S(KSS) + DUM
  401 KS=KS + 2
  400 KL=KL + 2*ND - 2*J + 1
C
      IF (IST.EQ.3) GO TO 300
      KL=1
      DO 420 J=1,ND,2
      DB3=TAU33*B(4,J)
      DO 421 I=J,ND,2
      S(KL)=S(KL) + DB3*B(4,I)
  421 KL=KL + 2
  420 KL=KL + ND - J
      GO TO 300
C
  500 KS=1
      DO 510 J=1,ND,2
      DB1=TAU11*B(1,J) + TAU12*B(3,J)
      DB2=TAU12*B(1,J) + TAU22*B(3,J)
      DO 512 I=J,ND,2
      SGNL(KS)=SGNL(KS) + B(1,I)*DB1 + B(3,I)*DB2
  512 KS=KS+1
  510 CONTINUE
C
  300 CONTINUE
C
C
      RETURN
      END
C *CDC* *DECK QUADM
C *UNI* )FOR,IS  N.QUADM,  R.QUADM
      SUBROUTINE QUADM (NEL,ND,XM,CM,XX,NOD5)
C
C
C       ROUTINE TO CALCULATE THE MASS MATRIX OF
C           A QUADRILATERAL ELEMENT.
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 /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      DIMENSION CM(1),XM(24),D(16),XX(2,8),NOD5(1)
      DIMENSION H(8),P(2,8)         ,XJ(2,2)
C
      EQUIVALENCE (NPAR(5),ITYP2D)
C
C
C       INTEGRATE --- CONSISTENT OR LUMPED MASS MATRIX
C
      IINTP=0
      IF (IMASS.EQ.1) GO TO 9
      DO 8 I=1,300
    8 CM(I)=0.
    9 DO 7 I=1,ND
    7 XM(I)=0.
C
      DO 100 LX=1,3
      R=XG(LX,3)
      DO 100 LY=1,3
      S=XG(LY,3)
      WT=WGT(LX,3)*WGT(LY,3)
C
C
C     FIND INTERPOLATION FUNCTIONS AND JACOBIAN
C
      CALL FUNCT2 (R,S,H,P,NOD5,XJ,DET,XX,NEL,IINTP)
C
C     COMPUTE THE RADIUS AT POINT (R,S)
C
      IF (ITYP2D.EQ.0) GO TO 40
      IF (ITYP2D.GT.0) XBAR=THIC
      GO TO 60
   40 XBAR=0.0
      DO 50 K=1,IEL
   50 XBAR=XBAR + H(K)*XX(1,K)
C
   60 FAC=WT*XBAR*DET*DE
C
C     CONSISTENT MASS
C
      NDPN=2
      IF(ITYP2D.EQ.3)NDPN=3
      IF (IMASS.LT.2) GO TO 320
      DO 200 I = 1,IEL
      D(2*I-1) = H(I)
  200 D(2*I) = H(I)
      KL=1
      ND1=2*IEL
      NDPN2=NDPN-2
      NDPN1=NDPN-1
      DO 300 I=1,ND1,2
      DO 301 J=I,ND1,2
      CM(KL)=CM(KL) + D(I)*D(J)*FAC
  301 KL=KL + NDPN
  300 KL=KL+(ND-(I+((I-1)/2)*NDPN2))*NDPN1-NDPN2
      GO TO 100
C
C     LUMPED MASS
C
  320 FACM=FAC/IEL
      DO 325 I=1,ND,NDPN
  325 XM(I)=XM(I) + FACM
C
  100 CONTINUE
C
      IF (IMASS.EQ.1) GO TO 335
      IF(NDPN.EQ.3)GO TO 410
C
      KL=1
      DO 401 I=1,ND,2
      KS=KL + ND - I + 1
      DO 400 J=I,ND,2
      CM(KS)=CM(KL)
      KS=KS + 2
  400 KL=KL + 2
  401 KL=KL + ND - I
C
      RETURN
C
C
C       THREE DIMENSIONAL CASE
C
  410 KL=1
      DO 451 I=1,ND,3
      KS1=KL+ND-I+1
      KS2=KS1+ND-I
      DO 450 J=I,ND,3
      CM(KS1)=CM(KL)
      CM(KS2)=CM(KL)
      KL=KL+3
      KS1=KS1+3
      KS2=KS2+3
  450 CONTINUE
      KL=KL+2*(ND-I)-1
  451 CONTINUE
C
      RETURN
C
C
C
C
C
  335 DO 340 I=1,ND,NDPN
  340 XM(I+1)=XM(I)
      IF (NDPN.LT.3) RETURN
      DO 350 I=1,ND,3
  350 XM(I+2)=XM(I)
C
      RETURN
C
C
      END
C *CDC* *DECK DERIQ
C *UNI* )FOR,IS  N.DERIQ,  R.DERIQ
      SUBROUTINE DERIQ (NEL,XX,B,DET,R,S,X1BAR,NOD5)
C
C
C     EVALUATION OF THE STRAIN-DISPLACEMENT MATRIX AT POINT (R,S) FOR
C     A QUADRILATERAL ELEMENT, AXISYMMETRIC GEOMETRY
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 /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
      DIMENSION     XX(2,1),B(4,1),NOD5(1)
      DIMENSION     H(8),         P(2,8),XJ(2,2),XJI(2,2)
C
      EQUIVALENCE (NPAR(5),ITYP2D)
C
C
C     FIND INTERPOLATION FUNCTIONS AND JACOBIAN
C
      IINTP=0
      CALL FUNCT2 (R,S,H,P,NOD5,XJ,DET,XX,NEL,IINTP)
C
C
C     COMPUTE INVERSE OF THE JACOBIAN MATRIX
C
      DUM = 1.0/DET
      XJI(1,1) = XJ(2,2)* DUM
      XJI(1,2) =-XJ(1,2)* DUM
      XJI(2,1) =-XJ(2,1)* DUM
      XJI(2,2) = XJ(1,1)* DUM
C
C     EVALUATE GLOBAL DERIVATIVE OPERATOR ( B-MATRIX )
C
      DO 130 K=1,IEL
      K2=K*2
      B(1,K2-1) = 0.
      B(1,K2  ) = 0.
      B(2,K2-1) = 0.
      B(2,K2  ) = 0.
      DO 120 I=1,2
      B(1,K2-1) = B(1,K2-1) + XJI(1,I) * P(I,K)
  120 B(2,K2  ) = B(2,K2  ) + XJI(2,I) * P(I,K)
      B(3,K2  ) = B(1,K2-1)
  130 B(3,K2-1) = B(2,K2  )
C
C     IN CASE OF PLANE STRAIN OR PLANE STRESS ANALYSIS WE DO NOT INCLUDE
C     THE NORMAL STRAIN COMPONENT
C
      IF (ITYP2D.GT.0) RETURN
C
C     COMPUTE THE RADIUS AT POINT (R,S)
C
      X1BAR = 0.0
      DO 50 K=1,IEL
   50 X1BAR = X1BAR + H(K)* XX(1,K)
C
C     EVALUATE THE HOOP STRAIN-DISPLACEMENT RELATION
C
      IF (X1BAR.GT..00000001D0) GO TO 150
C
C     FOR THE CASE OF ZERO RADIUS EQUATE RADIAL TO HOOP STRAIN
C
      ND=2*IEL
      DO 140 K=1,ND
  140 B(4,K)=B(1,K)
      RETURN
C
C     NON-ZERO RADIUS
C
  150 DUM = 1.0/X1BAR
      DO 160 K=1,IEL
      K2=K*2
      B(4,K2  ) = 0.
  160 B(4,K2-1) = H(K) * DUM
C
      RETURN
C
C
      END
C *CDC* *DECK FUNCT2
C *UNI* )FOR,IS  N.FUNCT2, R.FUNCT2
      SUBROUTINE FUNCT2 (R,S,H,P,NOD5,XJ,DET,XX,NEL,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 POINTS      .
C .      OF A 4- TO 8-NODE ISOPARAMETRIC QUADRILATERAL                .
C .                                                                   .
C .      TO FIND JACOBIAN ( XJ ) AND ITS DETERMINANT ( DET )          .
C
C .                                                                   .
C .                    NODE NUMBERING CONVENTION                      .
C
C .                                                                   .
C .               2                 5                 1               .
C .                                                                   .
C .                 O . . . . . . . O . . . . . . . O                 .
C .                 .                               .                 .
C .                 .                               .                 .
C .                 .               S               .                 .
C .                 .               .               .                 .
C .                 .               .               .                 .
C .               6 O               . . . R         O 8               .
C .                 .                               .                 .
C .                 .                               .                 .
C .                 .                               .                 .
C .                 .                               .                 .
C .                 .                               .                 .
C .                 O . . . . . . . O . . . . . . . O                 .
C .                                                                   .
C .               3                 7                 4               .
C .                                                                   .
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 /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
      DIMENSION H(1),P(2,1),NOD5(1),IPERM(4),XJ(2,2),XX(2,1)
C
      EQUIVALENCE (NPAR(8),IDEGEN)
C
      DATA IPERM/2,3,4,1/
C
      RP = 1.0 + R
      SP = 1.0 + S
      RM = 1.0 - R
      SM = 1.0 - S
      R2 = 1.0 - R*R
      S2 = 1.0 - S*S
C
C
C     INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C
C     4-NODE ELEMENT
C
      H(1) = 0.25* RP* SP
      H(2) = 0.25* RM* SP
      H(3) = 0.25* RM* SM
      H(4) = 0.25* RP* SM
      P(1,1)=0.25*SP
      P(1,2)=-P(1,1)
      P(1,3)=-0.25*SM
      P(1,4)=-P(1,3)
      P(2,1)=0.25*RP
      P(2,2)=0.25*RM
      P(2,3)=-P(2,2)
      P(2,4)=-P(2,1)
C
      IF (IEL.EQ.4) GO TO 80
C
C     ADD DEGREES OF FREEDOM IN EXCESS OF 4
C
      I=0
    2 I=I + 1
      IF (I.GT.NND5) GO TO 40
      NN=NOD5(I) - 4
      GO TO (5,6,7,8), NN
C
    5 H(5) = 0.50* R2* SP
      P(1,5)=-R*SP
      P(2,5)=0.50*R2
      GO TO 2
    6 H(6) = 0.50* RM* S2
      P(1,6)=-0.50*S2
      P(2,6)=-RM*S
      GO TO 2
    7 H(7) = 0.50* R2* SM
      P(1,7)=-R*SM
      P(2,7)=-0.50*R2
      GO TO 2
    8 H(8) = 0.50* RP* S2
      P(1,8)=0.50*S2
      P(2,8)=-RP*S
      GO TO 2
C
C     CORRECT FUNCTIONS AND DERIVATIVES IF 5 OR MORE NODES ARE
C     USED TO DESCRIBE THE ELEMENT
C
   40 IH=0
   41 IH=IH + 1
      IF (IH.GT.NND5) GO TO 50
      IN=NOD5(IH)
      I1=IN - 4
      I2=IPERM(I1)
      H(I1)=H(I1) - 0.5*H(IN)
      H(I2)=H(I2) - 0.5*H(IN)
      H(IH + 4)=H(IN)
      DO 45 J=1,2
      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 + 4)=P(J,IN)
      GO TO 41
C
C     CORRECT APPROPRIATE INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     FOR DEGENERATED 8-NODE ELEMENTS WITH NODES 1,4,8 COLLAPSED
C
   50 IF (IDEGEN.LE.0) GO TO 80
      IF (ISOCOR.LE.0) GO TO 80
C
      DH2D=R2*S2
      H(2)=H(2) + 0.125*DH2D
      H(3)=H(3) + 0.125*DH2D
      H(6)=H(6) - 0.25*DH2D
C
      P(1,2)=P(1,2) - 0.25*R*S2
      P(2,2)=P(2,2) - 0.25*S*R2
      P(1,3)=P(1,3) - 0.25*R*S2
      P(2,3)=P(2,3) - 0.25*S*R2
      P(1,6)=P(1,6) + 0.5*R*S2
      P(2,6)=P(2,6) + 0.5*S*R2
C
C     EVALUATE THE JACOBIAN MATRIX AT POINT (R,S)
C
   80 IF (IINTP.GT.0) RETURN
      DO 100 I=1,2
      DO 100 J=1,2
      DUM = 0.0
      DO 90 K=1,IEL
   90 DUM = DUM + P(I,K)* XX(J,K)
  100 XJ(I,J) = DUM
C
C     COMPUTE THE DETERMINANT OF THE JACOBIAN MATRIX AT POINT (R,S)
C
      DET = XJ(1,1)* XJ(2,2) - XJ(2,1)* XJ(1,2)
      IF (DET.GT..00000001D0) GO TO 110
      WRITE (6,2000) NG,NEL
      STOP
  110 CONTINUE
C
      RETURN
C
C
 2000 FORMAT (////14H *** ERROR ***/18H ELEMENT GROUP NO.,I5/
     1        44H ZERO JACOBIAN DETERMINANT FOR 2/D ELEMENT (,I4,1H))
C
      END
C *CDC* *DECK MAXMIN
C *UNI* )FOR,IS  N.MAXMIN, R.MAXMIN
      SUBROUTINE MAXMIN (STRESS,P1,P2,AG)
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION STRESS(1)
C
C
      CC = (STRESS(1)+STRESS(2)) * 0.5
      BB = (STRESS(1)-STRESS(2)) * 0.5
      CR =  DSQRT(BB**2 + STRESS(3)**2)
      P1 =  CC+CR
      P2 =  CC-CR
      AG=45.0
      IF (DABS(BB).LT..00000001D0) RETURN
C
      AG =  28.648D0* DATAN2(STRESS(3),BB)
C
      RETURN
C
      END
C *CDC* *DECK STSTL
C *UNI* )FOR,IS  N.STSTL,  R.STSTL
      SUBROUTINE STSTL (NEL,XX,PROP,C)
C
C
C .      TO GENERATE THE GLOBAL STRESS-STRAIN LAW FOR
C .      ISOTROPIC AND ORTHOTROPIC MATERIALS
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 /TODIM/ BET,THIC,DE,IEL,NND5,ISOCOR
C
      DIMENSION XX(2,1),PROP(1),C(4,1),D(4,4),T(4,4)
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(15),MODEL)
C
C
      GO TO (1,2), MODEL
C
C
C
C.... MODEL = 1    L I N E A R   I S O T R O P I C
C
    1 YM=PROP(1)
      PV=PROP(2)
      C1=YM/(1+PV)
      B1=C1*PV/(1.-2.*PV)
      A1=B1+C1
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=0.
      C(2,1)=B1
      C(2,2)=A1
      C(2,3)=0.
      C(3,1)=0.
      C(3,2)=0.
      C(3,3)=C1/2.
C
      IF (ITYP2D.EQ.1) RETURN
C
      C(1,4)=B1
      C(2,4)=B1
      C(3,4)=0.
      C(4,1)=B1
      C(4,2)=B1
      C(4,3)=0.
      C(4,4)=A1
C
      IF (ITYP2D.LT.2) RETURN
C
C     FOR PLANE STRESS ANALYSIS CONDENSE STRESS-STRAIN MATRIX
C
      GO TO 95
C
C
C
C.... MODEL = 2    L I N E A R   O R T H O T R O P I C
C
    2 IF (PROP(3).EQ.0.) GO TO 1
      PI=4.0*DATAN(1.0D0)
C
C     COMPUTE THE ANGLE BETWEEN EDGE 1-2 AND THE GLOBAL X-AXIS
C
      DX = XX(1,2) - XX(1,1)
      DY = XX(2,2) - XX(2,1)
      XL = DX**2 + DY**2
      IF (XL.GT..00000001D0) GO TO 102
      WRITE(6,2000) NEL
      STOP
  102 XL = DSQRT(XL)
      SA = DABS(DY/XL)
      SFIX=DSQRT(1.D0-SA*SA)
      AL = DATAN2(SA,SFIX)
      IF(DX.GE.0.0 .AND. DY.GE.0.0) P12 =         AL
      IF(DX.LT.0.0 .AND. DY.GE.0.0) P12 = PI    - AL
      IF(DX.LT.0.0 .AND. DY.LT.0.0) P12 = PI    + AL
      IF(DX.GE.0.0 .AND. DY.LT.0.0) P12 = PI*2.0- AL
C
C     COMPUTE THE ANGLE BETWEEN THE MATERIAL A-AXIS AND GLOBAL X-AXIS
C
      PI2=PI*2.
      IF(DABS(P12).GT.PI2) STOP
      GAM=P12 + BET
      IF (GAM.GE.PI2) GAM=GAM-PI2
C
C     SET THE COORDINATE TRANSFORMATION FOR ROTATION OF PROPERTIES
C
      IF (DABS(GAM).LT..00000001D0) GO TO 202
      SG = DSIN(GAM)
      CG = DCOS(GAM)
      T(1,1) =  CG**2
      T(1,2) =  SG**2
      T(1,3) =  CG* SG
      T(1,4) =  0.0
      T(2,1) =  T(1,2)
      T(2,2) =  T(1,1)
      T(2,3) = -T(1,3)
      T(2,4) =  0.0
      T(3,1) =  T(2,3)* 2.0
      T(3,2) = -T(3,1)
      T(3,3) =  T(1,1)- T(1,2)
      T(3,4) =  0.0
      T(4,1) =  0.0
      T(4,2) =  0.0
      T(4,3) =  0.0
      T(4,4) =  1.0
  202 CONTINUE
C
C     FORM THE STRAIN-STRESS LAW, SYSTEM (A,B,C)
C
      DUM = PROP(1)* PROP(2)* PROP(3)* PROP(7)
      IF (DUM.GT..00000001D0) GO TO 25
      WRITE(6,2010)
      STOP
   25 C(1,1) = 1.0/PROP(1)
      C(2,2) = 1.0/PROP(2)
      C(3,3) = 1.0/PROP(7)
      C(4,4) = 1.0/PROP(3)
      C(1,2) =-PROP(4)* C(2,2)
      C(1,4) =-PROP(5)* C(4,4)
      C(2,4) =-PROP(6)* C(4,4)
      C(1,3) = 0.0
      C(2,3) = 0.0
      C(3,4) = 0.0
      DO 30 I=1,4
      DO 30 J=I,4
   30 C(J,I) = C(I,J)
C
C     FORM THE STRESS-STRAIN LAW, SYSTEM (A,B,C)
C
      CALL POSINV (C,4,4)
C
C     ROTATE THE STRESS-STRAIN MATRIX TO GLOBAL COORDINATES
C
      IF (DABS(GAM).LT..00000001D0) GO TO 90
C
C     T(TRANSPOSE) * C(MATERIAL)
C
      DO 60 IR=1,4
      DO 60 IC=1,4
      D(IR,IC) = 0.0
      DO 50 IN=1,4
   50 D(IR,IC) = D(IR,IC) + T(IN,IR)* C(IN,IC)
   60 CONTINUE
C
C     T(TRANSPOSE) * C(MATERIAL) * T
C
      DO 80 IR=1,4
      DO 80 IC=IR,4
      C(IR,IC) = 0.0
      DO 70 IN=1,4
   70 C(IR,IC) = C(IR,IC) + D(IR,IN)* T(IN,IC)
   80 C(IC,IR)=C(IR,IC)
C
   90 IF (ITYP2D.LT.2) RETURN
C
C     FOR PLANE STRESS ANALYSIS CONDENSE STRESS-STRAIN MATRIX
C
   95 DO 110 I=1,3
      A=C(I,4)/C(4,4)
      DO 110 J=I,3
      C(I,J)=C(I,J) - C(4,J)*A
  110 C(J,I)=C(I,J)
      RETURN
C
C
C
 2000 FORMAT(10H0*** ERROR,/
     +       43H ZERO LENGTH BETWEEN NODES 1-2 IN ELEMENT (,I4,1H)  )
 2010 FORMAT(45H0***ERROR  MATERIAL PROPERTIES NOT ADMISSABLE  )
C
      END
C *CDC* *DECK POSINV
C *UNI* )FOR,IS  N.POSINV, R.POSINV
      SUBROUTINE POSINV (A,NMAX,NDD)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDD,NDD)
C
      DO 200 N=1,NMAX
C
      D=A(N,N)
      DO 100 J=1,NMAX
  100 A(N,J)=-A(N,J)/D
C
      DO 150 I=1,NMAX
      IF(N-I) 110,150,110
  110 DO 140 J=1,NMAX
      IF(N-J) 120,140,120
  120 A(I,J)=A(I,J)+A(I,N)*A(N,J)
  140 CONTINUE
  150 A(I,N)=A(I,N)/D
C
      A(N,N)=1.0/D
C
  200 CONTINUE
C
      RETURN
      END
C *CDC* *DECK STSTN
C *UNI* )FOR,IS  N.STSTN,  R.STSTN
      SUBROUTINE STSTN (XX,PROP,DISD,IDW,WA)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .   S U B R O U T I N E                                             .
C .                                                                   .
C .      TO FIND STRESS STRAIN LAW AND STRESSES FOR                   .
C .      NONLINEAR MATERIAL MODELS                                    .
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           ,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
C
      DIMENSION WA(IDW,1),XX(2,1),PROP(1),DISD(1),DN(4)
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(15),MODEL),(NPAR(3),INDNL)
     1           ,(NPAR(17),NCON)
C
C
      IST=3
      IF (ITYP2D.EQ.0) IST=4
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) + DISD(4)
      STRAIN(4)=0.
      IF (ITYP2D.EQ.0) STRAIN(4)=DISD(5)
      IF (INDNL.LE.1) GO TO 80
C
C     NONLINEAR STRAIN TERMS
C
      DN(1)=0.5*(DISD(1)*DISD(1) + DISD(4)*DISD(4))
      DN(2)=0.5*(DISD(2)*DISD(2) + DISD(3)*DISD(3))
      DN(3)=DISD(3)*DISD(1) + DISD(4)*DISD(2)
      IF (IST.EQ.4) DN(4)=0.5*DISD(5)*DISD(5)
C
      IF (INDNL.EQ.3) GO TO 60
C
C     CALCULATE GREEN-LAGRANGE STRAINS (TOTAL LAGRANGE FORMULATION)
C
      DO 20 I=1,IST
   20 STRAIN(I)=STRAIN(I) + DN(I)
      GO TO 80
C
C     CALCULATE ALMANSI STRAINS
C     (MODEL.EQ.1 AND UPDATED LAGRANGIAN FORMULATION)
C
   60 IF (MODEL.NE.1) GO TO 80
      DO 40 I=1,IST
   40 STRAIN(I)=STRAIN(I) - DN(I)
C
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,13,14,15,15) ,MODEL
C
C
C.... MODEL = 1    L I N E A R   I S O T R O P I C
C
C
    1 A1=C(1,1)
      B1=C(1,2)
C
      STRESS(1) = A1*STRAIN(1) + B1*STRAIN(2)
      STRESS(2) = B1*STRAIN(1) + A1*STRAIN(2)
      STRESS(3) = C(3,3)*STRAIN(3)
      STRESS(4) = 0.
C
C     PLANE STRESS PROBLEM
      A2=-PROP(2)/(1. - PROP(2))
      IF (ITYP2D.GE.2) STRAIN(4)=A2*(STRAIN(1) + STRAIN(2))
      IF (ITYP2D.GE.2) GO TO 110
C
C     PLANE STRAIN PROBLEM
      STRESS(4) = B1*(STRAIN(1)+STRAIN(2))
      IF (ITYP2D.EQ.1) GO TO 110
C
C     AXISYMMETRIC PROBLEM
C
      STRESS(1) = STRESS(1) + B1*STRAIN(4)
      STRESS(2) = STRESS(2) + B1*STRAIN(4)
      STRESS(4) = STRESS(4) + A1*STRAIN(4)
C
  110 RETURN
C
C
C.... MODEL = 2    L I N E A R   O R T H O T R O P I C
C
C
    2 IF (PROP(3).EQ.0.) GO TO 1
C
      DO 102 I=1,4
  102 STRESS(I)=0.
C
C     PLANE STRESS OR AXISYMMETRIC PROBLEM
C
      DO 103 J=1,IST
      DO 103 I=1,IST
  103 STRESS(I) = STRESS(I) + C(I,J)*STRAIN(J)
      IF (ITYP2D.GE.2) STRAIN(4)=
     1  -(C(4,1)*STRAIN(1)+C(4,2)*STRAIN(2)+C(4,3)*STRAIN(3))/C(4,4)
      IF (ITYP2D.NE.1) GO TO 120
C
C     PLANE STRAIN PROBLEM
C
      STRESS(4)=C(4,1)*STRAIN(1) + C(4,2)*STRAIN(2) + C(4,3)*STRAIN(3)
C
  120 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,3,1,6HRECALL)
    3 CALL ELT2D3
      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
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,3,2,6HRECALL)
    4 CALL ELT2D4
      RETURN
C
C
C.... MODEL = 6    (EMPTY)
C
C *CDC*     6 CALL OVERLAY (5HADINA,3,3,6HRECALL)
    6 CALL ELT2D6
      RETURN
C
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,3,4,6HRECALL)
    7 CALL ELT2D7
      RETURN
C
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,3,5,6HRECALL)
    8 CALL ELT2D8
      RETURN
C
C
C.... MODEL = 10,11    E L A S T I C - P L A S T I C + C R E E P
C
C *CDC*    10 CALL OVERLAY (5HADINA,3,6,6HRECALL)
   10 CALL EL2D10
      RETURN
C
C
C.... MODEL = 12    (EMPTY)
C
C *CDC*    12 CALL OVERLAY (5HADINA,3,7,6HRECALL)
   12 CALL EL2D12
      RETURN
C
C
C.... MODEL = 13    I N C O M P R E S S I B L E   E L A S T I C
C
C *CDC*    13 CALL OVERLAY (5HADINA,3,8,6HRECALL)
   13 CALL EL2D13
      RETURN
C
C
C.... MODEL = 14    ELASTIC - PLASTIC (MODIFIED CAMBRIDGE)
C
C *CDC*    14 CALL OVERLAY (5HADINA,3,9,6HRECALL)
   14 CALL EL2D14
      RETURN
C
C
C.... MODEL = 15,16  (EMPTY)
C
C *CDC*    15 CALL OVERLAY (5HADINA,3,10,6HRECALL)
   15 CALL EL2D15
      RETURN
C
C
C
      END
C *CDC* *DECK CAUCHY
C *UNI* )FOR,IS  N.CAUCHY, R.CAUCHY
      SUBROUTINE CAUCHY
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .     CONVERTS PIOLA-KIRCHHOFF STRESSES                             .
C .          TO CAUCHY STRESSES                                       .
C .                                                                   .
C .     CS   =   (1./DET(F)) * (F * PK * F(TRANSPOSED))               .
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 /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),D(4,4),IPT,NEL,IPS
      EQUIVALENCE (NPAR(5),ITYP2D)
C
C
      IF (ITYP2D-1) 710,720,730
  710 X33=1.+DISD(5)
      GO TO 750
  720 X33=1.
      GO TO 750
  730 X33=DSQRT (1.+2.*STRAIN(4))
C
  750 X11=1.+DISD(1)
      X12=   DISD(3)
      X22=1.+DISD(2)
      X21=   DISD(4)
C
      DET=X33*(X11*X22 - X12*X21)
      IF (DET .GT. 0.) GO TO 760
      WRITE(6,2100) NEL,KSTEP,DET
      STOP
C
  760 DET=1./DET
      S1=STRESS(1)
      S2=STRESS(2)
      SS=STRESS(3)
C
      STRESS(1)=DET * (S1*X11*X11 + 2.*SS*X11*X12 + S2*X12*X12)
      STRESS(2)=DET * (S1*X21*X21 + 2.*SS*X21*X22 + S2*X22*X22)
      STRESS(3)=DET * (S1*X11*X21 + SS*(X11*X22+X12*X21) + S2*X12*X22)
      IF (ITYP2D.GE.2) RETURN
      STRESS(4)=DET * (STRESS(4)*X33*X33)
C
      RETURN
C
C
 2100 FORMAT (40H DETERMINANT NOT POSITIVE                           /
     1        12H ELEMENT   =,I5/ 12H TIME STEP =,I5/ 8H DET   =,
     2        E14.6//38H STOP                                   )
C
      END
C *CDC* *DECK CGDT2
C *UNI* )FOR,IS  N.CGDT2,R.CGDT2
C
      SUBROUTINE CGDT2 (YZ,EDIS,NDPN,NOD5,E1,E2,IDEATH,EDISB,IEL,
     1                  ITYP2D)
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 /MATMOD/ STRESS(4),STRAIN(4),D(4,4),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(5),B(4,16),YZ(1),EDISB(1),EDIS(1),NOD5(1),
     2          XX(24),DUMMY1(24),DUMMY2(300)
C
      DATA IPRM /2,3,1/
C
C        1. CALCULATE DISPLACEMENT DERIVATIVES
C           (W.R.T. THE INITIAL CONFIGURATION)
C
      ND=NDPN*IEL
      DO 500 I=1,ND
  500 XX(I)=YZ(I)
      IF (IDEATH.NE.1) GO TO 510
C
      DO 505 I=1,ND
  505 XX(I)=XX(I) + EDISB(I)
C
  510 ND=2*IEL
      IF (NDPN.EQ.3) CALL PLST3D (YZ,XX,DUMMY1,EDIS,DUMMY2,IEL,3)
C
      CALL DERIQ (NEL,XX,B,DET,E1,E2,XBAR,NOD5)
C
      DO 515 I=1,5
  515 DISD(I)=0.0
C
      DO 520 J=2,ND,2
      I=J - 1
      DISD(1)=DISD(1) + B(1,I)*EDIS(I)
      DISD(2)=DISD(2) + B(2,J)*EDIS(J)
      DISD(3)=DISD(3) + B(3,I)*EDIS(I)
  520 DISD(4)=DISD(4) + B(3,J)*EDIS(J)
C
      IF (ITYP2D.NE.0) GO TO 550
      DO 525 I=1,ND,2
  525 DISD(5)=DISD(5) + B(4,I)*EDIS(I)
C
C        2. CALCULATE THE DEFORMATION GRADIENT TENSOR
C
  550 IF (ITYP2D - 1) 1,2,3
C
    1 F(3,3)=DISD(5) + 1.0
      GO TO 4
    2 F(3,3)=1.0
      GO TO 4
    3 F(3,3)=DSQRT(1.0 + 2.0*STRAIN(4))
C
    4 F(1,1)=DISD(1) + 1.0
      F(1,2)=DISD(3)
      F(1,3)=0.0
      F(2,1)=DISD(4)
      F(2,2)=DISD(2) + 1.0
      F(2,3)=0.0
      F(3,1)=0.0
      F(3,2)=0.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           DSIN(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.D0*PI/3.D0) + STRAV
      PV(2)   =A1*DSIN(PHI) + STRAV
      PV(3)   =A1*DSIN(PHI + 4.D0*PI/3.D0) + 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 CGDT2))
C
      END
C *CDC* *DECK OVL 31
C *CDC*       OVERLAY (ADINA,3,1)
C *CDC* *DECK ELT2D3
C *UNI* )FOR,IS  N.ELT2D3, R.ELT2D3
C *CDC*       PROGRAM ELT2D3
C
C
C
      SUBROUTINE ELT2D3
C
C
C
C     MODEL = 3   (THERMOELASTIC MODEL)
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 /DPR/ ITWO
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON A(1)
C
      REAL A
C
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(7),MXNODS),(A(1),IA(1))
      EQUIVALENCE (NPAR(17),NCON)
C
C
C
C
C     FOR ADDRESSES N101,N102,...............SEE SUBROUTINE TODMFE
C
C     QUANTITIES STORED FOR EACH ELEMENT
C
C        GLOBAL NODAL POINT NUMBERS
C
C
C
      NN=N110+(NEL-1)*MXNODS
      IF(IND.NE.0) GO TO 100
C
C        1. INITIALIZE WORKING ARRAY
C
      CALL ITHEL2(A(NN))
      GO TO 200
C
C        2. DETERMINE MATERIAL PROPERTY SET NUMBER
C
  100 MATP=IA(N107+NEL-1)
C
C        3. DETERMINE MATERIAL PROPERTY LOCATION
C
      NM=N109+(MATP-1)*NCON*ITWO
C
C        4. DETERMINE MIDSIDE NODE ARRAY LOCATION
C
      ND5DIM=MXNODS-4
      LL=N111+(NEL-1)*ND5DIM
C
C        5. CALCULATE STRESSES AND CONSTITUTIVE LAW
C
      CALL THEL2(A(NM),A(NN),A(N6B + ITWO),A(LL))
C
  200 CONTINUE
C
      RETURN
      END
C *CDC* *DECK ITHEL2
C *UNI* )FOR,IS  N.ITHEL2, R.ITHEL2
C
      SUBROUTINE ITHEL2(IWA)
C
C
C
C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR THE
C     THERMOELASTIC MATERIAL MODEL  (MODEL = 3)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      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 /DPR/ ITWO
C
      DIMENSION IWA(1)
C
C
C        1. STORE GLOBAL NODAL POINT NUMBERS
C
      II=0
      DO 15 K=1,8
      IF(NODM(K).EQ.0) GO TO 15
      II=II+1
      IWA(II)=NODM(K)
   15 CONTINUE
C
      RETURN
C
      END
C *CDC* *DECK THEL2
C *UNI* )FOR,IS  N.THEL2, R.THEL2
C
      SUBROUTINE THEL2(PROP,NDS,TEMPV2,NOD5M)
C
C
C
C     THIS SUBROUTINE CALCULATES THE STRESSES AND THE CONSTITUTIVE
C     LAW FOR THE THERMOELASTIC MATERIAL MODEL  (MODEL = 3)
C
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        IST = NUMBER OF STRESS COMPONENTS
C        ISR = NUMBER OF STRAIN COMPONENTS
C        PROP2 = MATERIAL PROPERTIES AT END OF CURRENT SOLUTION STEP
C                PROP2(1) = YOUNGS MODULUS
C                PROP2(2) = POISSONS RATIO
C                PROP2(3) = MEAN COEFFICIENT OF THERMAL EXPANSION
C        TEMP2 = TEMPERATURE AT END OF CURRENT SOLUTION STEP
C        TREF =  REFERENCE TEMPERATURE
C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
C        STRESS = STRESSES
C        STRAIN = TOTAL STRAINS
C        TEMPV2 = NODAL POINT TEMPERATURES AT END OF CURRENT SOLUTION
C                 STEP
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 /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 /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 /TODIM/ BET,THIC,DE,IEL,NND5
C
      DIMENSION PROP2(3),PROP(16,1),EPST(4),NDS(1),TEMPV2(1),NOD5M(1),
     1          H(8),XDM1(2,8),XDM2(2,2),XDM3(2,1)
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(3),INDNL)
C
      DATA NGLAST/1000/
C
C
C
      IF(IPT.GT.1) GO TO 5
      TOLMT=1.0D-2
      NPTS=IDINT(PROP(1,5))
      TREF=PROP(2,5)
C
      IINTP=1
      IST=4
      IF (ITYP2D .GE. 2) IST=3
      ISR=3
      IF(ITYP2D.EQ.0) ISR=4
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        1. INTERPOLATE NODAL POINT TEMPERATURES
C
    5 CALL FUNCT2(E1,E2,H,XDM1,NOD5M,XDM2,XDUM,XDM3,NEL,IINTP)
      TEMP2=0.0
      DO 10 K=1,IEL
      KK=NDS(K)
   10 TEMP2=TEMP2+H(K)*TEMPV2(KK)
C
C        2. INTERPOLATE MATERIAL PROPERTY TABLES
C
      IF(TEMP2.GE.RNGL) GO TO 35
      WRITE(6,2008)
      STOP
C
   35 L=0
      DO 40 K=2,NPTS
      L=L+1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(TEMP2.GT.DUM) GO TO 40
      GO TO 45
   40 CONTINUE
      WRITE(6,2008)
      STOP
C
   45 RATIO=(TEMP2-PROP(L,1))/(PROP(L+1,1)-PROP(L,1))
C
C     CORRECT RATIO FOR THE CASE WHEN TEMP2 LIES OUTSIDE TABLE, BUT
C     WITHIN THE TOLERANCE RANGE **
C
      IF(RATIO.GT.1.0) RATIO=1.0
      IF(RATIO.LT.0.0) RATIO=0.0
C
      DO 60 M=2,4
   60 PROP2(M-1)=PROP(L,M)+RATIO*(PROP(L+1,M)-PROP(L,M))
C
C        3. CALCULATE ELASTIC PROPERTIES AT END OF STEP
C
      YM2=PROP2(1)
      PV2=PROP2(2)
      A22=YM2/(1.+PV2)
      C12=0.5*A22
      A22=A22/(1.-2.*PV2)
      B22=A22*PV2
      A22=A22-B22
      E12=YM2/(1.-2.*PV2)
      IF (ITYP2D .GE. 2) GO TO 75
C
C     PLANE STRAIN/AXISYMMETRIC **
C
      A12=A22
      B12=B22
      GO TO 80
C
C     PLANE STRESS **
C
   75 A12=YM2/(1.-PV2*PV2)
      B12=A12*PV2
      D12=PV2/(PV2-1.)
      E12=YM2/(1.-PV2)
C
C        4. CALCULATE THERMAL STRAINS AT END OF STEP
C
   80 EPST(1)=PROP2(3)*(TEMP2-TREF)
      EPST(2)=EPST(1)
      EPST(3)=0.0
      EPST(4)=EPST(1)
C
C        5. CALCULATE STRESSES
C
C     PLANE STRESS **
C
      STRESS(1)=A12*STRAIN(1)+B12*STRAIN(2)-E12*EPST(1)
      STRESS(2)=B12*STRAIN(1)+A12*STRAIN(2)-E12*EPST(2)
      STRESS(3)=C12*STRAIN(3)
      IF (ITYP2D .GE. 2) GO TO 90
C
C     PLANE STRAIN **
C
      STRESS(4)=B12*(STRAIN(1)+STRAIN(2))-E12*EPST(4)
      IF(ITYP2D.EQ.1) GO TO 90
C
C     AXISYMMETRIC **
C
      STRESS(1)=STRESS(1)+B12*STRAIN(4)
      STRESS(2)=STRESS(2)+B12*STRAIN(4)
      STRESS(4)=STRESS(4)+A12*STRAIN(4)
C
C        6. CHECK FOR PRINTING
C
   90 IF(KPRI.EQ.0) GO TO 190
C
C        7. CHECK FOR EQUILIBRIUM ITERATION
C
      IF(ICOUNT.EQ.3) RETURN
C
C        8. CALCULATE CONSTITUTIVE LAW USING TEMPERATURES AT
C           END OF STEP
C
      DO 115 I=1,4
      DO 115 J=1,4
  115 C(I,J)=0.0
C
C     PLANE STRAIN **
C
      C(1,1)=A12
      C(1,2)=B12
      C(2,1)=B12
      C(2,2)=A12
      C(3,3)=C12
C
      IF(ITYP2D-1) 125,120,130
  120 RETURN
C
C     AXISYMMETRIC **
C
  125 C(1,4)=B12
      C(2,4)=B12
      C(4,1)=B12
      C(4,2)=B12
      C(4,4)=A12
      RETURN
C
C     PLANE STRESS **
C
  130 C(4,1)=B22
      C(4,2)=B22
      C(4,3)=0.0
      C(4,4)=A22
      RETURN
C
C        9. PRINTING OF STRESSES
C
C
  190 IF(INDNL.NE.2) GO TO 200
C
C     IN TOTAL LAGRANGIAN FORMULATION, CALCULATE CAUCHY STRESSES **
C
      CALL CAUCHY
C
  200 IF (IPRI.NE.0) RETURN
      IF (NG.NE.NGLAST) GO TO 202
      IF(NEL.GT.NELAST) GO TO 206
      IF(IPT-1) 210,208,210
C
  202 NGLAST=NG
  208 IF(ITYP2D-1) 205,205,203
  203 WRITE(6,2002)
      GO TO 206
  205 WRITE(6,2003)
  206 NELAST=NEL
      WRITE(6,2004) NEL
  210 CALL MAXMIN(STRESS,SX,SY,SM)
      IF(ITYP2D-1) 215,215,213
  213 WRITE(6,2005) IPT,(STRESS(I),I=1,3),SX,SY,SM
      WRITE(6,2009) TEMP2
      RETURN
C
  215 WRITE(6,2007) IPT,STRESS(4),(STRESS(I),I=1,3),SX,SY,SM
      WRITE(6,2009) TEMP2
      RETURN
C
 2002 FORMAT(100H ELEMENT  STRESS      STRESS-YY     STRESS-ZZ     STRES
     1S-YZ        MAX STRESS    MIN STRESS    ANGLE,/,8H NUM/IPT,/)
 2003 FORMAT(114H ELEMENT  STRESS      STRESS-XX     STRESS-YY     STRES
     1S-ZZ     STRESS-YZ        MAX STRESS    MIN STRESS    ANGLE,/,8H N
     1UM/IPT,/)
 2004 FORMAT(I4,/)
 2005 FORMAT(5X,I2,10X,3E14.6,3X,2E14.6,3X,F6.2)
 2007 FORMAT(5X,I2,10X,4E14.6,3X,2E14.6,3X,F6.2)
 2008 FORMAT(92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PROPER
     1TY TEMPERATURES   (SUBROUTINE THEL2))
 2009 FORMAT(6X,14HTEMPERATURE = ,E14.6,/)
C
      END
C *CDC* *DECK OVL32
C *CDC*       OVERLAY (ADINA,3,2)
C *CDC* *DECK ELT2D4
C *UNI* )FOR,IS  N.ELT2D4, R.ELT2D4
C *CDC*       PROGRAM ELT2D4
      SUBROUTINE ELT2D4
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   M O D E L
C     W I T H   O R   W I T H O U T   T E N S I O N   C U T - O F F
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
      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 /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCR2/ BETA,GAMA,RKAPA,ALFA,SIGP(4),TEP(4),EP(4),YP(3),
     1                E,VNU,RK,G,E12,E14,E24,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /DPR/ ITWO
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(7),MXNODS),(NPAR(10),NINT),(NPAR(17),NCON)
      EQUIVALENCE (A(1),IA(1))
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE TODMFE
C
      IDW=15*ITWO
      NPT=NINT*NINT
      MATP=IA(N107 + NEL - 1)
      NM=N109 + (MATP - 1)*NCON*ITWO
      NNOD=N110 + (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   A R R A Y
C
C
   50 NDM=2*MXNODS
      NO=N102 + (NEL - 1)*NDM*ITWO
      ND5DIM=MXNODS - 4
      NOO=N111 + (NEL - 1)*ND5DIM
C
      IF (IND.NE.0) GO TO 100
C
      NN=N110 + (NEL - 1)*IDW*NPT
      IF (NPAR(19).GT.0) NN=NN + (NEL - 1)*MXNODS
C
      CALL ICDMOD (NEL,NPT,A(NM),A(NN),A(NO),A(NOO),IA(NNOD),A(N6A1))
C
      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
C
      NN=N110 + (NEL - 1)*IDW*NPT + (IPT - 1)*IDW
      IF (NPAR(19).GT.0) NN=NN + (NEL - 1)*MXNODS
      NN4=NN + 4*ITWO
      NN8=NN + 8*ITWO
      NN9=NN8 + ITWO
      NN10=NN9 + ITWO
      NN11=NN10 + ITWO
      NN12=NN11 + ITWO
C
      CALL CDMOD (NEL,A(NM),A(NMI),A(NMI2),A(NMI3),A(NMI4),A(NN),A(NN4),
     1            A(NN8),A(NN9),A(NN10),A(NN11),A(NN12),STRESS,STRAIN,D,
     2            IPT,IA(NNOD),A(N6A1),A(N6B1),A(NO),A(NOO),A(NN))
C
  599 CONTINUE
      RETURN
C
      END
C *CDC* *DECK ICDMOD
C *UNI* )FOR,IS  N.ICDMOD, R.ICDMOD
      SUBROUTINE ICDMOD (NEL,NPT,PROP,WA,YZ,NOD5,NODS,TEMPV1)
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 /TODIM/ BET,THIC,DE,IEL,NND5
      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),E1,E2,E3
      COMMON /EM2D/ S(300),XM(24),B(4,16),RE(24),EDIS(24),EDISI(24),
     1              XX(24),NOD(8),NODM(8),NOD5M(4)
      DIMENSION PROP(1),WA(15,1),YZ(1),NOD5(1),NODS(1),TEMPV1(1)
      DIMENSION H(8),P(2,8),XJ(2,2),PGRV(6)
C
      EQUIVALENCE (NPAR(17),NCON),(NPAR(10),NINT),(NPAR(15),MODEL),
     1            (NPAR(19),ITHERM)
C
C
C     INITIALIZE WA
C
      DO 11 J=1,NPT
      DO 10 I=1,15
   10 WA(I,J)=0.
   11 WA(12,J)=1000.
      IF (ITHERM.EQ.0) GO TO 18
      II=0
      DO 15 K=1,8
      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 IINTP=1
      DO 100 LX=1,NINT
      R1=XG(LX,NINT)
      DO 100 LZ=1,NINT
      S1=XG(LZ,NINT)
      IPT=(LX-1)*NINT + LZ
C
      CALL FUNCT2 (R1,S1,H,P,NOD5,XJ,DET,YZ,NEL,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(10,IPT)=TMPOLD
      GO TO 100
C
   25 KK=0
      ZDEPTH=0.
      DO 30 K=1,IEL
      KK=KK + 2
   30 ZDEPTH=ZDEPTH + H(K)*YZ(KK)
      PGRAV=-GAMMA*ZDEPTH
      WA(11,IPT)=PGRAV
C
  100 CONTINUE
      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(11,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(10,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
C *CDC* *DECK CDMOD
C *UNI* )FOR,IS  N.CDMOD,  R.CDMOD
      SUBROUTINE CDMOD (NEL,EKK,RKLD,RKUN,GLD,SP33,SIG,EPS,EVMAX,
     1                  EVGRAV,PGRAV,ANGLE,CRKSTR,STRESS,STRAIN,C,IPT,
     2                  NODS,TEMPV1,TEMPV2,YZ,NOD5,WA)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .   MODEL  4       CDMOD WITH OR WITHOUT TENSION CUT-OFF            .
C .      EKK       STRAIN ABCISSAE                                    .
C .      RKLD      LOADING BULK MODULUS                               .
C .      RKUN      UNLOADING BULK MODULUS                             .
C .      GLD       LOADING SHEAR MODULUS                              .
C .      EVMAX     MAXIMUM VOLUMETRIC STRAIN EVER REACHED (COMP +)    .
C .      EVGRAV    VOLUMETRIC STRAIN DUE TO GROUND PRESSURE (COMP +)  .
C .      PGRAV     GROUND PRESSURE (COMP +)                           .
C .                                                                   .
C .   MODEL  5       CONCRETE STRUCTURE MODEL                         .
C .      EKK       YOUNG@S MODULUS AND POISSON@S RATIO                .
C .      RKLD,RKUN,GLD,SP33  COMPRESSIVE FAILURE CURVES DATA          .
C .      EVMAX     MAXIMUM VALUE OF LOADING FUNCTION EVER REACHED     .
C .      EVGRAV    INTERPOLATED TEMPERATURE OF PREVIOUS TIME STEP     .
C .      PGRAV     INDICATOR  SET TO 100. IF CRUSHING FAILURE OCCURS  .
C .                                                                   .
C .      SIG       STRESSES FROM THE PREVIOUS TIME STEP               .
C .      EPS       STRAINS  FROM THE PREVIOUS TIME STEP               .
C .      ANGLE     DIRECTION OF CRACK                                 .
C .      CRKSTR    STRAINS AT WHICH CRACKS OPENED                     .
C .                                                                   .
C .      STRESS    CURRENT STRESSES                                   .
C .      STRAIN    CURRENT STRAINS                                    .
C .      C         CURRENT ELASTICITY MODULUS MATRIX                  .
C .      IPT       INTEGRATION POINT INDICATOR                        .
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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCR2/ BETA,GAMA,RKAPA,ALFA,SIGP(4),TEP(4),EP(4),YP(3),
     1                E,VNU,RK,G,E12,E14,E24,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),F1,F2,F3
C
      DIMENSION EKK(1),RKLD(1),RKUN(1),GLD(1),SP33(1),SIG(4),EPS(4),
     1          CRKSTR(3),STRESS(4),STRAIN(4),C(4,4),NODS(1),TEMPV1(1),
     2          TEMPV2(1),YZ(1),NOD5(1),WA(1),DUMWA(15)
      EQUIVALENCE (SIGP(1),P1),(SIGP(2),P2),(SIGP(4),P3)
C
C
      EQUIVALENCE (NPAR(5),ITYP2D),(NPAR(17),NCON),(NPAR(10),NINT)
     1           ,(NPAR(15),MODEL),(NPAR(19),ITHERM),(NPAR(3),INDNL)
      IF (IUPDT.EQ.0) GO TO 2
      DO 1 I=1,15
    1 DUMWA(I)=WA(I)
C
C
    2 IF (MODEL.EQ.5) GO TO 3
      FALSTR=PGRAV
      EVTOT=EVMAX + EVGRAV
      IF (ITYP2D.LT.2) GO TO 3
      WRITE(6,2005)
      STOP
    3 NPT=NINT*NINT
      IPOINT=6
      MOD45=1
      NUMCRK=0
      ANGPRI=1000.
      ILFSET=0
C
C
C        1. CALCULATE STRESS AND STRAIN DEVIATORS
C           OF THE PREVIOUS TIME STEP
C
C
      TMM=(SIG(1)+SIG(2)+SIG(4))/3.
      T11=SIG(1) - TMM
      T22=SIG(2) - TMM
      T33=SIG(4) - TMM
      T12=SIG(3)
C
      EVV=-(EPS(1)+EPS(2)+EPS(4))
      EMM=-EVV/3.
      E11=EPS(1) - EMM
      E22=EPS(2) - EMM
      E33=EPS(4) - EMM
      E12=EPS(3)
      SBAR=((SIG(1)-SIG(2))**2+(SIG(1)-SIG(4))**2+(SIG(2)-SIG(4))**2)/6.
      IF (MODEL.EQ.5) EVV=DSQRT(SBAR + SIG(3)**2) + 3.*ALFA*TMM
C
C
C        2. CALCULATE PARAMETERS BASED ON STRESSES AND STRAINS
C           OF THE PREVIOUS UPDATE
C
C
      IKAS=1
      IF (DABS(EVV-EVMAX).GT.DABS(EVMAX)*1.D-8) IKAS=-1
      IK=1
      ITEM=1
C
C **  OBTAIN MATERIAL PROPERTIES FOR CONCRETE (MODEL=5)  * * * *
C
    5 IF (MODEL.EQ.4) GO TO 10
C
C     UNLOADING/RELOADING - USE INITIAL YOUNGS MODULUS, ISOTROPIC LAW
C
      E=EKK(1)
      VNU=EKK(2)
      TMPOLD=EVGRAV
      IF (ITYP2D.GE.2) STRAIN(4)=(STRAIN(1) + STRAIN(2))*VNU/(VNU - 1.)
C
C     CHECK WHETEHER ALREADY COMPLETELY FAILED IN COMPRESSION
C
      IF (PGRAV.NE.100.) GO TO 12
      IKAS=1
      E=E*STIFAC
      SIGCP=CRKSTR(1)
      EPSCP=CRKSTR(2)
      IF (EVV.EQ.0.) GO TO 45
      E=EKK(1)
C
C     LOADING
C
   12 IF (ITEM.NE.1) GO TO 7
      IF (IKAS.GT.0 .AND. (ANGLE.GT.361. .OR. PGRAV.EQ.100.))
     1 CALL PRNCPL (SIG,EPS,ANG,RKLD,RKUN,GLD,SP33,TEP,PGRAV,MODEL,1)
C
      IF (ANGLE.LT.361. .AND. PGRAV.NE.100.)
     1  CALL CRAKID (SIG,EPS,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     2               ANGLE,TEP,NUMCRK,MODEL,1)
C
C     ROTATE INCREMENTAL STRAINS TO PREVIOUS TIME PRINCIPAL/CRACK PLANES
C
      IF (IKAS.GT.0 .AND. (ANGLE.GT.361. .OR. PGRAV.EQ.100.))
     1 CALL PRNCPL (SIG,STRAIN,ANG,RKLD,RKUN,GLD,SP33,EP,PGRAV,MODEL,2)
C
      IF (ANGLE.LT.361. .AND. PGRAV.NE.100.)
     1  CALL CRAKID (SIG,STRAIN,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     2               ANGLE,EP,NUMCRK,MODEL,2)
      IF (IKAS.LT.0) GO TO 45
C
C     NUMERICAL INTEGRATION TO COMPUTE TANGENT MODULI
C
      NUMINT=3
    7 IF (ITEM.EQ.2) NUMINT=1
      DENM=DABS(P1) + DABS(P2) + DABS(P3)
      IF (DENM.LE.0.00001*SIGMAT) GO TO 45
C
      RP=EPSU/EPSC
      ES=SIGCP/EPSCP
      EU=(SIGMAU*SIGCP/SIGMAC)/(EPSU*EPSCP/EPSC)
      RAM5=EKK(1)/EU + (RP - 2.)*RP*RP*EKK(1)/ES - (2.*RP+1)*(RP-1.)**2
      RAM5=RAM5/(RP*(RP - 1.)**2)
      RBM5=2.*EKK(1)/ES - 3. - 2.*RAM5
      RCM5=2. - EKK(1)/ES + RAM5
C
      N1=1
      N2=4
      IF (PGRAV.NE.100.) GO TO 9
      N1=4
      IF (SIGP(2).LT.SIGP(4)) N1=2
      N2=N1
    9 DO 6 J=N1,N2
      IF (J.EQ.3) GO TO 6
      I=J
      IF (J.EQ.4) I=3
      YP(I)=E
      IF (SIGP(J).GE.0.001*SIGCP) GO TO 6
C
      YP(I)=0.
      DO 4 L=1,NUMINT
      E1=XG(L,NUMINT)
      DE=TEP(J) + (1 + E1)*(EP(J) - TEP(J))/2.
      DE=DE/EPSCP
      TY=E
      IF (DE.LE.0.) GO TO 4
      TY=E*(1. - RBM5*DE*DE - 2.*RCM5*DE**3)
      TY=TY/(1. + RAM5*DE + RBM5*DE*DE + RCM5*DE**3)**2
    4 YP(I)=YP(I) + 0.5*WGT(L,NUMINT)*TY
    6 CONTINUE
C
C     ALREADY FAILED IN COMPRESSION
C
      IF (PGRAV.NE.100.) GO TO 8
      E=YP(I)
      IF (E.GT.0.) E=0.
      GO TO 45
C
C     EQUIVALENT ISOTROPIC LAW
C
    8 MOD45=1
      DE=RKAPA*SIGCP
      IF (P1.LT.DE .OR. P2.LT.DE .OR. P3.LT.DE) MOD45=2
      E=(DABS(P1)*YP(1) + DABS(P2)*YP(2) + DABS(P3)*YP(3))/DENM
      IF (MOD45.EQ.1) GO TO 45
C
C     ORTHOTROPIC STRESS-STRAIN LAW
C
      E12=E
      DENM=DABS(P1) + DABS(P2)
      IF (DENM.NE.0.) E12=(DABS(P1)*YP(1) + DABS(P2)*YP(2))/DENM
      E14=E
      DENM=DABS(P1) + DABS(P3)
      IF (DENM.NE.0.) E14=(DABS(P1)*YP(1) + DABS(P3)*YP(3))/DENM
      E24=E
      DENM=DABS(P2) + DABS(P3)
      IF (DENM.NE.0.) E24=(DABS(P2)*YP(2) + DABS(P3)*YP(3))/DENM
      GO TO 45
C
C **  OBTAIN MATERIAL PROPERTIES FOR CDMODEL (MODEL=4)   * * * *
C
   10 DO 15 L=IK,IPOINT
      J=L
      IF (EVTOT.LT.EKK(J)) GO TO 28
   15 CONTINUE
      WRITE(6,2015) EVTOT,NEL,EKK(IPOINT)
      STOP
C
   28 I=J-1
C
      DELEV=EKK(J) - EKK(I)
      DELEI=EVTOT - EKK(I)
      RATIO=DELEI / DELEV
C
      IF (IKAS) 30,35,35
C
   30 RKUNLO=RKUN(I) + RATIO * (RKUN(J) - RKUN(I))
   35 RK =RKLD(I) + RATIO * (RKLD(J) - RKLD(I))
      G    =GLD(I) + RATIO * ( GLD(J) - GLD(I) )
C
      IF (IKAS) 40,45,45
C
   40 G=G * (RKUNLO/RK)
      RK=RKUNLO
C
   45 IF (ITEM.EQ.2) GO TO 100
C
C
C        3. IF CRACKING HAS OCCURRED, USE PARAMETERS CALCULATED IN (2.)
C           WITH CRACKED MODEL TO FIND CURRENT STRESSES BASED ON
C           GIVEN STRAINS
C
C
      IF (MODEL.EQ.5) GO TO 46
      IF (ICRACK.LT.1) GO TO 50
      IF (ANGLE.GT.361.) GO TO 50
      CALL CRAKID (SIG,EPS,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     1             ANGLE,TEP,NUMCRK,MODEL,1)
C
      CALL CRAKID (SIG,STRAIN,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     1             ANGLE,EP,NUMCRK,MODEL,2)
      GO TO 47
C
   46 RK=E/(3.*(1. - 2.*VNU))
      G=E/(2.*(1. + VNU))
      IF (PGRAV.EQ.100.) GO TO 50
      IF (ANGLE.GT.361. .AND. MOD45.EQ.1) GO TO 50
C
   47 CALL DCRACK (C,SIG,ANGLE,MODEL,ITYP2D,NUMCRK,1,1)
C
      K=3
      SIGP(K)=SIGP(K) + C(K,K)*(EP(K) - TEP(K))
      IST=4
      IF (ITYP2D.GE.2) IST=2
      DO 57 I=1,IST
      DO 57 J=1,IST
      IF (I.EQ.3 .OR. J.EQ.3) GO TO 57
      SIGP(I)=SIGP(I) + C(I,J)*(EP(J) - TEP(J))
   57 CONTINUE
C
      EVI=-(STRAIN(1) + STRAIN(2) + STRAIN(4))
C
      IF (MODEL.EQ.4) GO TO 58
      TEP(1)=EP(1)
      TEP(2)=EP(2)
      TEP(4)=EP(4)
   58 IF (ANGLE.LT.361.)
     1  CALL CRAKID (STRESS,STRAIN,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     2               ANGLE,EP,NUMCRK,MODEL,3)
C
      IF (ANGLE.LT.361.) ANG=ANGLE
      CALL DCRACK (C,STRESS,ANG,MODEL,ITYP2D,NUMCRK,1,2)
      IF (ANGLE.GT.361.0) GO TO 60
C
      GO TO 65
C
C
C        4. IF THERE IS NO CRACKING ON PREVIOUS TIME STEP, USE ISOTROPIC
C           LAW WITH PARAMETERS CALCULATED IN (2.) TO FIND CURRENT
C           STRESSES BASED ON GIVEN STRAINS
C
C
   50 EVI=-(STRAIN(1) + STRAIN(2) + STRAIN(4))
      EPSMM=-EVI/3.
      EPS11=STRAIN(1)-EPSMM
      EPS22=STRAIN(2)-EPSMM
      EPS33=STRAIN(4)-EPSMM
      EPS12=STRAIN(3)
C
      PEE=3.*RK*(EPSMM - EMM) + TMM
C
      S11=2.*G*(EPS11-E11)+T11
      S22=2.*G*(EPS22-E22)+T22
      S33=2.*G*(EPS33-E33)+T33
      S12=   G*(EPS12-E12)+T12
C
      STRESS(1)=S11+PEE
      STRESS(2)=S22+PEE
      STRESS(4)=S33+PEE
      STRESS(3)=S12
      IF (ITYP2D .GE. 2) STRESS(4)=0.
C
C
C        5. DETERMINE WHETHER CURRENT STRESSES HAVE CAUSED CRACKING
C           OR CRUSHING TO OCCUR
C
C
   60 CALL PRNCPL (STRESS,STRAIN,ANG,RKLD,RKUN,GLD,SP33,EP,PGRAV,
     1             MODEL,1)
      IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 65
C
C     CHECK FOR COMPLETE STRESS RELEASE IF CONCRETE HAS ALREADY CRUSHED
C
      IF (MODEL.NE.5) GO TO 59
      TEP(1)=EP(1)
      TEP(2)=EP(2)
      TEP(4)=EP(4)
      IF (PGRAV.NE.100.) GO TO 59
      NUMCRK=3
      CALL DCRACK (C,STRESS,ANGLE,MODEL,ITYP2D,NUMCRK,2,2)
      FALSTR=SIGCP
      IF (KPRI.EQ.0) GO TO 65
      GO TO 70
C
C     TEST TO SEE CRACKING OR CRUSHING OCCURS FOR THE FIRST TIME
C
   59 IF (KPRI.EQ.0) GO TO 65
C
      IF (MODEL.GT.4) GO TO 150
      IF (P1 .GT. PGRAV) ANGLE=ANG
      IF (STRESS(4) .GT. PGRAV) ANGLE=ANG - 361.
      IF (ANGLE .GT. 361.) GO TO 65
      NUMCRK=0
      IF (P1 .GT. PGRAV) NUMCRK=1
      IF (P2.GT.PGRAV) NUMCRK=2
      IF (NUMCRK.EQ.2) ANGLE=-ANGLE
      CRKSTR(1)=EP(1)
      CRKSTR(2)=EP(2)
      CRKSTR(3)=EP(4)
      IF (STRESS(4) .GT. PGRAV) NUMCRK=NUMCRK + 4
      IF (NUMCRK.EQ.5) ANGLE=ANG - 722.
      IF (NUMCRK.EQ.6) ANGLE=-ANG - 361.
C
      CALL DCRACK (C,STRESS,ANGLE,MODEL,ITYP2D,NUMCRK,1,2)
      ILFSET=1
C
C
C        6. PRINT STRESSES
C
C
   65 IF (KPRI.NE.0) GO TO 70
      IF (IPRI.NE.0) GO TO 66
      IF (IPT.NE.1) GO TO 66
      IF (NEL .EQ. 1) WRITE (6,2000)
      WRITE(6,2035) NEL
   66 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 67
      IF (ANGLE.LT.361.) GO TO 165
      IF (MODEL.GT.4) GO TO 150
      PTOT=-PGRAV + P1
      IF (PTOT.GT.0.0) ANGPRI=ANG
      IF (STRESS(4) .GT. PGRAV) ANGPRI=ANG
      IF (P1.GT.PGRAV) NUMCRK=1
      IF (P2.GT.PGRAV) NUMCRK=2
      IF (STRESS(4).GT.PGRAV) NUMCRK=NUMCRK + 4
      GO TO 160
C
C     CHECK FOR CRACKING OR CRUSHING OF CONCRETE FOR THE FIRST TIME
C
  150 IF (P1.LT.0. .AND. P3.LT.0.) GO TO 155
      IF (P1.GT.FALSTR) NUMCRK=1
      IF (P2.GT.FALSTR) NUMCRK=2
      IF (P3.GT.FALSTR) NUMCRK=NUMCRK + 4
  155 IF (P2.LT.SIGCP .OR. P3.LT.SIGCP) NUMCRK=3
      IF (NUMCRK.GT.0) ANGPRI=ANG
      IF (NUMCRK.EQ.3) FALSTR=SIGCP
C
      IF (KPRI.EQ.0) GO TO 160
      IF (NUMCRK.EQ.0) GO TO 70
      ANGLE=ANG
      IF (NUMCRK.EQ.2) ANGLE=-ANGLE
      IF (NUMCRK.GE.4) ANGLE=ANGLE - 361.
      IF (NUMCRK.EQ.5) ANGLE=ANG - 722.
      CRKSTR(1)=EP(1)
      CRKSTR(2)=EP(2)
      CRKSTR(3)=EP(4)
C
      IF (NUMCRK.NE.3) GO TO 159
      PGRAV=100.
      CRKSTR(1)=SIGCP
      CRKSTR(2)=EPSCP
C
  159 CALL DCRACK (C,STRESS,ANGLE,MODEL,ITYP2D,NUMCRK,1,2)
      ILFSET=1
      GO TO 70
C
  160 IF (ANGPRI.GT.361.0) GO TO 67
      CALL DCRACK (C,STRESS,ANGPRI,MODEL,ITYP2D,NUMCRK,1,2)
      GO TO 166
C
  165 ANGPRI=ANGLE
      IF (ANGPRI.LT.-541.) ANGPRI=ANGPRI + 722.
      IF (ANGPRI .LT. (-180.)) ANGPRI=ANGPRI + 361.
      IF (ANGPRI .LT. 0.) ANGPRI=-ANGPRI
      IF (ANGPRI.GT.180.) ANGPRI=ANGPRI - 180.
C
  166 NF=NUMCRK + 1
      IF (INDNL .EQ. 2) CALL CAUCHY
      IF (IPRI.NE.0) GO TO 70
      IF (NF .GT. 5) NF=NF - 3
      IF (NUMCRK .EQ. 6) GO TO 68
      GO TO (61,62,63,64,62) ,NF
   61 WRITE (6,2040) IPT,(STRESS(I),I=1,4),P1,P2,ANGPRI,FALSTR
      GO TO 70
   62 WRITE (6,2041) IPT,(STRESS(I),I=1,4),P1,P2,ANGPRI,FALSTR
      GO TO 70
   63 WRITE (6,2042) IPT,(STRESS(I),I=1,4),P1,P2,ANGPRI,FALSTR
      GO TO 70
   64 WRITE (6,2043) IPT,(STRESS(I),I=1,4),P1,P2,ANGPRI,FALSTR
      GO TO 70
   68 WRITE (6,2045) IPT,(STRESS(I),I=1,4),P1,P2,ANGPRI,FALSTR
      GO TO 70
   67 IF (INDNL .EQ. 2) CALL CAUCHY
      IF (IPRI.NE.0) GO TO 70
      WRITE (6,2044) IPT,(STRESS(I),I=1,4),P1,P2,ANG,FALSTR
C
C
C        7. UPDATE STRESSES AND STRAINS
C
C
   70 SIG(1)=STRESS(1)
      SIG(2)=STRESS(2)
      SIG(3)=STRESS(3)
      SIG(4)=STRESS(4)
C
      EPS(1)=STRAIN(1)
      EPS(2)=STRAIN(2)
      EPS(3)=STRAIN(3)
      EPS(4)=STRAIN(4)
      IF (KPRI .EQ. 0) RETURN
      IF (ICOUNT.EQ.3) RETURN
      IF (MODEL.EQ.4) GO TO 71
      IF (PGRAV.NE.100.) GO TO 69
      E=0.
      GO TO 100
C
   69 SBAR=((SIG(1)-SIG(2))**2+(SIG(1)-SIG(4))**2+(SIG(2)-SIG(4))**2)/6.
      EVI=DSQRT(SBAR + SIG(3)**2) + ALFA*(SIG(1) + SIG(2) + SIG(4))
      IF (IKAS.EQ.1 .AND. ILFSET.EQ.1) EVMAX=EVI
   71 IF (EVI.GT.EVMAX) EVMAX=EVI
C
C
C        8. FORM THE STRESS-STRAIN RELATIONSHIP
C
C
C
C     IN DIVERGENCE FORMULATION (IEQREF=1) FORM THE INITIAL ELASTIC C
C
      IF (IEQREF.EQ.1) GO TO 85
C
      IF (EVI.LT.EVMAX) GO TO 75
C
C     NOW LOADING BEYOND PREVIOUS MAXIMUM VALUE
C
   74 IF (MODEL.EQ.4) EVTOT=EVMAX + EVGRAV
      IK=J
      IKAS=1
      ITEM=2
      GO TO 5
C
   75 IF (IKAS) 100,85,85
C
C     WAS LOADING, NOW UNLOADING FROM THE CURRENT MAXIMUM
C
   85 IF (MODEL.EQ.4) GO TO 90
      E=EKK(1)
      VNU=EKK(2)
      MOD45=1
      GO TO 100
C
   90 RKUNLO=RKUN(I) + RATIO * (RKUN(J) - RKUN(I))
      G=G*(RKUNLO/RK)
      RK=RKUNLO
C
C     WAS UNLOADING, NOW FURTHUR UNLOADING OR RELOADING TO PREVIOUS MAX
C
  100 IF (MODEL.EQ.4) GO TO 95
      IF (E.LE.0.) E=EKK(1)*STIFAC
      RK=E/(3.*(1. - 2.*VNU))
      G=E/(2.*(1. + VNU))
      IF (PGRAV.EQ.100.) GO TO 101
      IF (MOD45.EQ.2) GO TO 110
   95 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 101
      IF (ANGLE.LT.361.) GO TO 110
C
C     ISOTROPIC STRESS-STRAIN LAW
C
  101 DUM=0.6666667D0* G
      A1=RK + 2.*DUM
      B1=RK - DUM
C
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=0.
      C(2,1)=B1
      C(2,2)=A1
      C(2,3)=0.
      C(3,1)=0.
      C(3,2)=0.
      C(3,3)=G
C
      IF (ITYP2D.EQ.1) GO TO 200
C
      C(1,4)=B1
      C(2,4)=B1
      C(3,4)=0.
      C(4,1)=B1
      C(4,2)=B1
      C(4,3)=0.
      C(4,4)=A1
C
      IF (ITYP2D.LT.2) GO TO 200
C
      DO 105 I=1,2
      A=C(I,4)/C(4,4)
      DO 105 J=I,2
      C(I,J)=C(I,J) - C(4,J)*A
  105 C(J,I)=C(I,J)
C
      GO TO 200
C
C     CRACKED / ORTHOTROPIC STRESS-STRAIN LAW
C
  110 IF (ANGLE.LT.361.) ANG=ANGLE
      CALL DCRACK (C,STRESS,ANG,MODEL,ITYP2D,NUMCRK,2,1)
C
  200 IF (ITHERM.GT.0)
     1   CALL THERM2 (NODS,NOD5,YZ,EKK,TEMPV2,EPS,TMPOLD,ITYP2D)
      IF (MODEL.EQ.5) EVGRAV=TMPOLD
C
      IF (IUPDT.EQ.0) RETURN
      DO 210 I=1,15
  210 WA(I)=DUMWA(I)
      RETURN
C
C
 2000 FORMAT (///23H  ELEMENT   INTEGRATION,75X,7H(PGRAV),
     +        /19H  NUMBER      POINT ,4X,
     1        2X,7HSIGMAYY,4X,7HSIGMAZZ,4X,7HSIGMAYZ,4X,7HSIGMAXX,
     2        3X,8HSIGMA P1,3X,8HSIGMA P2,3X,5HANGLE,3X,7HFAILSTR/)
 2005 FORMAT(49H **STOP - PLANE STRESS CANNOT BE USED WITH CDMOD  )
 2015 FORMAT(///36H ***ERROR  CURRENT VOLUMETRIC STRAIN,E14.6,2X,
     1       13HFOR ELEMENT (,I2,1H)/11X,21HEXCEEDS TABLE MAXIMUM,
     2       E14.6//8H ***STOP)
 2035 FORMAT (I9)
 2040 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8HCLOSED   )
 2041 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8H1 CRACK  )
 2042 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8H2 CRACKS )
 2043 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8HCRUSHED  )
 2045 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8H3 CRACKS )
 2044 FORMAT (9X,I10,4X,6E11.3,F7.2,E11.3,10X,8HNO CRACK )
C
      END
C *CDC* *DECK PRNCPL
C *UNI* )FOR,IS N.PRNCPL, R.PRNCPL
      SUBROUTINE PRNCPL (STR,EPS,ANG,SP1,SP31,SP32,SP33,EPSL,PGRAV,
     1                   MODEL,KKK)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCR2/ BETA,GAMA,RKAPA,ALFA,SIGP(4),TEP(4),EP(4),YP(3),
     1                E,VNU,RK,G,E12,E14,E24,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
C
      DIMENSION STR(4),EPS(4),SP1(1),SP31(1),SP32(1),SP33(1),EPSL(4),
     1          SIG(3)
      IF (KKK.GT.1) GO TO 10
C
C     FIND PRINCIPAL STRESSES
C
      AA=(STR(1) + STR(2))*0.5
      BB=(STR(1) - STR(2))*0.5
      CC=DSQRT(BB*BB + STR(3)*STR(3))
      SIGP(1)=AA + CC
      SIGP(2)=AA - CC
      SIGP(3)=0.
      SIGP(4)=STR(4)
      ANG=45.0
      IF (STR(3).EQ.0.) ANG=0.0001
      IF (DABS(BB).LT.0.0000001D0) GO TO 10
      DUM=DABS(STR(3)/BB)
      ANG=57.296D0*DATAN(DUM)
C
      IF (BB.GT.0. .AND. STR(3).GT.0.) ANG=ANG
      IF (BB.LT.0. .AND. STR(3).GT.0.) ANG=180. - ANG
      IF (BB.LT.0. .AND. STR(3).LE.0.) ANG=180. + ANG
      IF (BB.GT.0. .AND. STR(3).LE.0.) ANG=360. - ANG
      ANG=ANG/2.
C
C     FIND PRINCIPAL STRAINS
C
   10 PI=4.0*DATAN(1.0D0)
      GAM=ANG*PI/180.
      SG=DSIN(GAM)
      CG=DCOS(GAM)
C
      EPSL(1)=EPS(1)*CG*CG + EPS(2)*SG*SG + EPS(3)*SG*CG
      EPSL(2)=EPS(1)*SG*SG + EPS(2)*CG*CG - EPS(3)*SG*CG
      EPSL(3)=0.
      EPSL(4)=EPS(4)
      IF (KKK.EQ.2) RETURN
      IF (MODEL.EQ.4) RETURN
      IF (PGRAV.EQ.100.) RETURN
      SIGCP=SIGMAC
      EPSCP=EPSC
      FALSTR=SIGMAT
C
C     ARRANGE PRINCIPAL STRESSES
C
      SIG(1)=SIGP(1)
      SIG(2)=SIGP(2)
      SIG(3)=SIGP(4)
  114 IS=0
      DO 116 I=1,2
      IF (SIG(I + 1).LE.SIG(I)) GO TO 116
      IS=IS + 1
      TEMP=SIG(I + 1)
      SIG(I + 1)=SIG(I)
      SIG(I)=TEMP
  116 CONTINUE
      IF (IS.GT.0) GO TO 114
      P1=SIG(1)
      P2=SIG(2)
      P3=SIG(3)
C
C     FIND FAILURE STRESSES FROM THE FAILURE ENVELOPE
C
      IF (P3.GE.0.) GO TO 180
      IF (P1.LT.0.) GO TO 135
      IF (P2.LT.0.) GO TO 130
      FALSTR=SIGMAT*(1. - P3/SIGMAC)
      GO TO 180
C
  130 SP31I=SP31(1)
      SP32I=SP32(1)
      SP33I=SP33(1)
      TEMP=0.
      GO TO 150
C
  135 TEMP=P1/SIGMAC
      DO 140 I=2,6
      J=I - 1
      IF (TEMP.LT.SP1(I)) GO TO 145
  140 CONTINUE
      WRITE (6,3000) P1
      WRITE (6,3100) NEL,IPT,P1,P2,P3
      STOP
C
  145 DSP=SP1(I) - SP1(J)
      DSPI=TEMP - SP1(J)
      FRAC=DSPI/DSP
      SP31I=SP31(J) + FRAC*(SP31(I) - SP31(J))
      SP32I=SP32(J) + FRAC*(SP32(I) - SP32(J))
      SP33I=SP33(J) + FRAC*(SP33(I) - SP33(J))
C
  150 RATIO=P2/SIGMAC
      IF (RATIO.GT.BETA*SP32I) GO TO 160
      SLOPE=(SP32I - SP31I)/(BETA*SP32I - TEMP)
      SIGCP=SP31I*SIGMAC + SLOPE*(P2 - P1)
      IF (P1.GT.0.) SIGCP=SP31I*SIGMAC + SLOPE*P2
      GO TO 170
  160 SLOPE=(SP33I - SP32I)/(SP33I - BETA*SP32I)
      SIGCP=SP32I*SIGMAC + SLOPE*(P2 - BETA*SP32I*SIGMAC)
C
  170 IF (SIGCP.LT.SIGMAC) EPSCP=GAMA*EPSC*SIGCP/SIGMAC
      IF (P1.GE.0.) FALSTR=SIGMAT*(1. - P2/SIGCP)*(1. - P3/SIGCP)
      IF (FALSTR.LT.0.001*SIGMAT) FALSTR=SIGMAT
      IF (P1.LT.0.) FALSTR=SIGCP
C
  180 RETURN
C
 3000 FORMAT (1H1,52H*** ERROR STOP, CURRENT VALUE OF PRINCIPAL STRESS 1
     1=,E15.5,50H IS LARGER THAN THE MAXIMUM INPUT VALUE FOR SP1(6))
 3100 FORMAT (//36H ERROR OCCURED IN SUBROUTINE PRNCPL.
     1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
     2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
C
      END
C *CDC* *DECK CRAKID
C *UNI* )FOR,IS N.CRAKID, R.CRAKID
      SUBROUTINE CRAKID (STR,EPS,PGRAV,CRKSTR,SP1,SP31,SP32,SP33,
     1                   ANGLE,EPSL,NUMCRK,MODEL,KKK)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCR2/ BETA,GAMA,RKAPA,ALFA,SIGP(4),TEP(4),EP(4),YP(3),
     1                E,VNU,RK,G,E12,E14,E24,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /MATMOD/ STRESS(4),STRAIN(4),D(4,4),IPT,NEL,IPS
C
      DIMENSION STR(4),EPS(4),CRKSTR(3),SP1(1),SP31(1),SP32(1),SP33(1),
     1          EPSL(4),SIG(3)
C
C     FIND STRESSES PERPENDICULAR AND PARALELL TO CRACK
C
      PI=4.0*DATAN(1.0D0)
      TANG=ANGLE
      IF (TANG.LT.-541.) TANG=TANG + 722.
      IF (TANG .LT. (-180.)) TANG=TANG + 361.
      IF (TANG.GE.180.) TANG=TANG - 180.
      GAM=2.*DABS(TANG)*PI/180.
      SG=DSIN(GAM)
      CG=DCOS(GAM)
      IF (KKK.EQ.2) GO TO 10
      IF (KKK.EQ.3) GO TO 107
C
      R11=(STR(1) + STR(2))*0.5
      R12=(STR(1) - STR(2))*0.5
      SIGP(1)=R11 + R12*CG + STR(3)*SG
      SIGP(2)=R11 - R12*CG - STR(3)*SG
      SIGP(3)=-R12*SG + STR(3)*CG
      SIGP(4)=STR(4)
C
   10 D11=(EPS(1) + EPS(2))*0.5
      D12=(EPS(1) - EPS(2))*0.5
      EPSL(1)=D11 + D12*CG + EPS(3)*SG*0.5
      EPSL(2)=D11 - D12*CG - EPS(3)*SG*0.5
      EPSL(3)=-D12*SG + EPS(3)*CG
      EPSL(4)=EPS(4)
      IF (KKK.EQ.2) RETURN
C
C     TEST TO SEE WHICH DIRECTIONS HAVE OPEN CRACKS AT CURRENT STRESSES
C
  107 NUMCRK=1
      IF (TANG.LT.0.) NUMCRK=2
      IF (ANGLE.GE.180.) NUMCRK=0
      IF (ANGLE.LT.-181.) NUMCRK=4
      IF (ANGLE.LT.-361.) NUMCRK=6
      IF (ANGLE.LT.-541.) NUMCRK=5
      NCROLD=NUMCRK
      FALSTR=PGRAV
      IF (MODEL.EQ.4) GO TO 109
      FALSTR=SIGMAT
      SIGCP=SIGMAC
      EPSCP=EPSC
      SIG(1)=SIGP(1)
      SIG(2)=SIGP(2)
      SIG(3)=SIGP(4)
C
  109 NF=NUMCRK + 1
      GO TO (110, 111, 180, 185, 195, 190, 190), NF
  110 IF (SIGP(1).LT.FALSTR .AND. SIGP(2).LT.FALSTR .AND. SIGP(4).LT.
     1    FALSTR) GO TO 112
      IF (SIGP(1).GT.FALSTR .OR. SIGP(2).GT.FALSTR) NUMCRK=1
      ANGLE=TANG
      CRKSTR(1)=EPSL(1)
      CRKSTR(2)=EPSL(2)
      CRKSTR(3)=EPSL(4)
      IF (SIGP(4).LT.FALSTR) GO TO 112
      NUMCRK=NUMCRK + 4
      ANGLE=ANGLE - 361.
      IF (NUMCRK.EQ.5) ANGLE=ANGLE - 361.
      GO TO 112
C
  111 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=0
      IF (NUMCRK.EQ.0) ANGLE=ANGLE + 180.
      IF (SIGP(2).LT.FALSTR) GO TO 113
      NUMCRK=2
      CRKSTR(2)=EPSL(2)
      ANGLE=-ANGLE
  113 IF (SIGP(4).LT.FALSTR) GO TO 112
      NUMCRK=NUMCRK + 4
      CRKSTR(3)=EPSL(4)
      ANGLE=ANGLE - 361.
      IF (NUMCRK.EQ.5) ANGLE=ANGLE - 361.
C
C     CHECK FOR COMPRESSIVE FAILURE OF CONCRETE
C
  112 IF (MODEL.EQ.4) RETURN
C
C     ARRANGE PRINCIPAL STRESSES
C
  114 IS=0
      DO 116 I=1,2
      IF (SIG(I+1).LE.SIG(I)) GO TO 116
      IS=IS + 1
      TEMP=SIG(I + 1)
      SIG(I + 1)=SIG(I)
      SIG(I)=TEMP
  116 CONTINUE
      IF (IS.GT.0) GO TO 114
      P1=SIG(1)
      P2=SIG(2)
      P3=SIG(3)
C
      IF (P3.GE.0.) GO TO 200
      IF (P2.LT.0.) GO TO 115
      IF (P3.GT.SIGMAC) GO TO 200
      GO TO 185
  115 IF (P1.LT.0.) GO TO 135
      SP31I=SP31(1)
      SP32I=SP32(1)
      SP33I=SP33(1)
      TEMP=0.
      GO TO 150
C
  135 TEMP=P1/SIGMAC
      DO 140 I=2,6
      J=I - 1
      IF (TEMP.LT.SP1(I)) GO TO 145
  140 CONTINUE
      WRITE (6,3000) P1
      WRITE (6,3100) NEL,IPT,P1,P2,P3
      STOP
C
  145 DSP=SP1(I) - SP1(J)
      DSPI=TEMP - SP1(J)
      FRAC=DSPI/DSP
      SP31I=SP31(J) + FRAC*(SP31(I) - SP31(J))
      SP32I=SP32(J) + FRAC*(SP32(I) - SP32(J))
      SP33I=SP33(J) + FRAC*(SP33(I) - SP33(J))
C
  150 RATIO=P2/SIGMAC
      IF (RATIO.GT.BETA*SP32I) GO TO 160
      SLOPE=(SP32I - SP31I)/(BETA*SP32I - TEMP)
      SIGCP=SP31I*SIGMAC + SLOPE*(P2 - P1)
      IF (P1.GT.0.) SIGCP=SP31I*SIGMAC + SLOPE*P2
      GO TO 170
  160 SLOPE=(SP33I - SP32I)/(SP33I - BETA*SP32I)
      SIGCP=SP32I*SIGMAC + SLOPE*(P2 - BETA*SP32I*SIGMAC)
  170 IF (SIGCP.LT.SIGMAC) EPSCP=GAMA*EPSC*SIGCP/SIGMAC
      IF (P3.LE.SIGCP) GO TO 185
      GO TO 200
C
  180 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=1
      IF (EPSL(2).LT.0. .AND. EPSL(2).LT.CRKSTR(2)) NUMCRK=NUMCRK - 1
      IF (NUMCRK.LT.2) ANGLE=DABS(ANGLE)
      IF (NUMCRK.EQ.0) ANGLE=ANGLE + 180.
      IF (SIGP(4).LT.FALSTR) GO TO 112
      NUMCRK=NUMCRK + 4
      CRKSTR(3)=EPSL(4)
      ANGLE=ANGLE - 361.
      IF (NUMCRK.EQ.5) ANGLE=ANGLE - 361.
      GO TO 112
C
  185 NUMCRK=3
      PGRAV=100.
      FALSTR=SIGCP
      CRKSTR(1)=SIGCP
      CRKSTR(2)=EPSCP
      GO TO 200
C
  190 IF (EPSL(2).LT.0. .AND. EPSL(2).LT.CRKSTR(2) .AND. NUMCRK.EQ.6)
     1           NUMCRK=5
      IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1) .AND. NUMCRK.EQ.5)
     1           NUMCRK=4
      IF (EPSL(4).LT.0. .AND. EPSL(4).LT.CRKSTR(3)) NUMCRK=NUMCRK - 4
      IF (NCROLD.NE.5) GO TO 112
      IF (SIGP(2).GE.FALSTR) NUMCRK=6
      IF (NUMCRK.EQ.6) ANGLE=-(ANGLE + 722.) - 361.
      GO TO 112
C
  195 CONTINUE
      R11=(SIGP(1) + SIGP(2))*0.5
      R12=(SIGP(1) - SIGP(2))*0.5
      RAD=DSQRT(R12*R12 + SIGP(3)*SIGP(3))
      SIG(1)=R11 + RAD
      SIG(2)=R11 - RAD
      IF (MODEL.EQ.5 .AND. SIG(2).LT.0.) FALSTR=SIGMAT*(1. - SIG(2)
     1                                                          /SIGMAC)
      IF (SIG(1).GT.FALSTR) NUMCRK=NUMCRK + 1
      IF (SIG(2).GT.FALSTR) NUMCRK=NUMCRK + 1
      IF (NUMCRK.EQ.4) GO TO 198
C
      S11=(EPSL(1) + EPSL(2))*0.5
      S12=(EPSL(1) - EPSL(2))*0.5
      RAD=DSQRT(S12*S12 + EPSL(3)*EPSL(3)/4.)
      EPS2=S11 + RAD
      EPS3=S11 - RAD
      IF (NUMCRK.GT.4) CRKSTR(1)=EPS2
      IF (NUMCRK.GT.4) CRKSTR(2)=EPS3
      SIGP(1)=SIG(1)
      SIGP(2)=SIG(2)
      EPSL(1)=EPS2
      EPSL(2)=EPS3
      EPSL(3)=0.
      ANG=45.
      IF (DABS(R12).GT.0.000001D0) ANG=DATAN2(SIGP(3),R12)*28.648D0
      ANG=ANG + TANG
      IF (ANG.LT.0.) ANG=ANG + 180.
      IF (NUMCRK.EQ.6) ANG=-ANG
      ANGLE=ANG
      SIGP(3)=0.
  198 IF (EPSL(4).LT.0. .AND. EPSL(4).LT.CRKSTR(3)) NUMCRK=NUMCRK - 4
      IF (NUMCRK.EQ.5) ANGLE=ANG - 722.
      IF (NUMCRK.EQ.6) ANGLE=ANG - 361.
      GO TO 112
C
  200 IF (KKK.EQ.3 .AND. NCROLD.NE.NUMCRK) ILFSET=1
      RETURN
C
 3000 FORMAT (1H1,52H*** ERROR STOP, CURRENT VALUE OF PRINCIPAL STRESS 1
     1=,E15.5,50H IS LARGER THAN THE MAXIMUM INPUT VALUE FOR SP1(6))
 3100 FORMAT (//36H ERROR OCCURED IN SUBROUTINE CRAKID.
     1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
     2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
      END
C *CDC* *DECK DCRACK
C *UNI* )FOR,IS  N.DCRACK, R.DCRACK
      SUBROUTINE DCRACK (C,SIG,ANGLE,MODEL,ITYP2D,NUMCRK,ILOCAL,KKK)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
     1               RAM5,RBM5,RCM5,ICRACK,MOD45
      COMMON /CONCR2/ BETA,GAMA,RKAPA,ALFA,SIGP(4),TEP(4),EP(4),YP(3),
     1                E,VNU,RK,G,E12,E14,E24,EPSCP,SIGCP,FALSTR,ILFSET
      DIMENSION C(4,4),SIG(4),D(4,4),T(4,4),DSIG(4)
C
      IF (KKK.EQ.2) GO TO 42
C
C     COMPUTE ISOTROPIC STRESS-STRAIN LAW
C
      IF (MOD45.EQ.2) GO TO 8
      DUM=2.0*G/3.0
      A1=RK + 2.*DUM
      B1=RK - DUM
C
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=0.
      C(1,4)=B1
      C(2,2)=A1
      C(2,3)=0.
      C(2,4)=B1
      C(3,3)=G
      C(3,4)=0.
      C(4,4)=A1
      GO TO 10
C
C     ORTHOTROPIC STRESS-STRAIN LAW
C
    8 A1=(1. + VNU)*(1. - 2.*VNU)
      B1=(1. - VNU)/A1
      D1=VNU/A1
      C1=1./(2.*(1. + VNU))
      C(1,1)=B1*YP(1)
      C(1,2)=E12*D1
      C(1,3)=0.
      C(1,4)=E14*D1
      C(2,2)=B1*YP(2)
      C(2,3)=0.
      C(2,4)=E24*D1
      C(3,3)=C1*E12
      C(3,4)=0.
      C(4,4)=B1*YP(3)
C
   10 IF (NUMCRK.EQ.0 .OR. NUMCRK.EQ.3) GO TO 35
C
C     MODIFY STRESS-STRAIN LAW TO ACCOUNT FOR CRACKING
C
      C(3,3)=C(3,3)*SHEFAC
      IF (MOD45.EQ.2) GO TO 13
      A2=4.*G*(RK+G/3.)/(RK+4.0*G/3.)
      B2=2.*G*(RK-2.*G/3.)/(RK+4.0*G/3.)
      C2=A2
      D2=(9.*RK*G)/(3.*RK + G)
      R2=A2
      S2=B2
      T2=A2
      W2=G
      Z2=D2
      GO TO 14
C
   13 A1=1./(1. - VNU*VNU)
      B1=VNU*A1
      A2=A1*YP(2)
      B2=B1*E24
      C2=A1*YP(3)
      D2=YP(3)
      R2=A1*YP(1)
      S2=B1*E12
      T2=A2
      W2=C1*E12
      Z2=E12
C
   14 GO TO (15, 20, 35, 25, 30, 33), NUMCRK
C
   15 DO 16 I=1,4
   16 C(1,I)=C(1,I)*STIFAC
      C(2,2)=A2
      C(2,4)=B2
      C(4,4)=C2
      GO TO 35
C
   20 DO 21 I=1,2
      DO 21 J=I,4
   21 C(I,J)=C(I,J)*STIFAC
      C(4,4)=D2
      GO TO 35
C
   25 DO 26 I=1,4
   26 C(I,4)=C(I,4)*STIFAC
      C(1,1)=R2
      C(1,2)=S2
      C(2,2)=T2
      C(3,3)=W2
      GO TO 35
C
   30 DO 31 I=1,4
      DO 31 J=I,4
   31 C(I,J)=C(I,J)*STIFAC
      C(2,2)=Z2
      C(3,3)=W2*SHEFAC
      GO TO 35
C
   33 DO 34 I=1,4
      DO 34 J=I,4
   34 C(I,J)=C(I,J)*STIFAC
      C(3,3)=W2*SHEFAC
C
   35 DO 40 I=1,3
      DO 40 J=I,4
   40 C(J,I)=C(I,J)
      IF (ILOCAL.EQ.1) GO TO 90
C
   42 IF (NUMCRK.NE.3) GO TO 43
      IF (KKK.EQ.1) GO TO 90
      IF (ILOCAL.EQ.2) GO TO 97
C
C     SET UP COORDINATE TRANSFORMATION FROM CRACKED ORIENTATION
C
   43 PI=4.0*DATAN(1.0D0)
      TANGLE=ANGLE
      IF (TANGLE.LT.-541.) TANGLE=TANGLE + 722.
      IF (TANGLE .LT. (-180.)) TANGLE=TANGLE + 361.
      IF (TANGLE.GT.180.) TANGLE=TANGLE - 180.
      GAM=DABS(TANGLE)*PI/180.
      SG = DSIN(GAM)
      CG = DCOS(GAM)
      T(1,1) =  CG**2
      T(1,2) =  SG**2
      T(1,3) =  CG* SG
      T(1,4) =  0.0
      T(2,1) =  T(1,2)
      T(2,2) =  T(1,1)
      T(2,3) = -T(1,3)
      T(2,4) =  0.0
      T(3,1) =  T(2,3)* 2.0
      T(3,2) = -T(3,1)
      T(3,3) =  T(1,1)- T(1,2)
      T(3,4) =  0.0
      T(4,1) =  0.0
      T(4,2) =  0.0
      T(4,3) =  0.0
      T(4,4) =  1.0
      IF (KKK.EQ.2) GO TO 97
C
C     ROTATE THE STRESS-STRAIN MATRIX TO GLOBAL COORDINATES
C
C     T(TRANSPOSE) * C(MATERIAL)
C
      DO 60 IR=1,4
      DO 60 IC=1,4
      D(IR,IC) = 0.0
      DO 50 IN=1,4
   50 D(IR,IC) = D(IR,IC) + T(IN,IR)* C(IN,IC)
   60 CONTINUE
C
C     T(TRANSPOSE) * C(MATERIAL) * T
C
      DO 80 IR=1,4
      DO 80 IC=IR,4
      C(IR,IC) = 0.0
      DO 70 IN=1,4
   70 C(IR,IC) = C(IR,IC) + D(IR,IN)* T(IN,IC)
   80 C(IC,IR)=C(IR,IC)
C
C
C     FOR PLANE STRESS ANALYSIS CONDENSE STRESS-STRAIN MATRIX
C
   90 IF (ITYP2D.LT.2) GO TO 97
      DO 95 I=1,3
      A=C(I,4)/C(4,4)
      DO 95 J=I,3
      C(I,J)=C(I,J) - C(4,J)*A
   95 C(J,I)=C(I,J)
C
   97 IF (KKK.LT.2) RETURN
      IF (MODEL.EQ.4 .AND. ICRACK.LT.2) GO TO 140
      ETATAU=0.
      IF (SHEFAC .GT. 0.001) ETATAU=1.
C
C     REDUCE CRACKED NORMAL ( + SHEAR)STRESSES OF PREVIOUS STEP TO ZERO
C
      DO 91 I=1,4
   91 DSIG(I)=0.
      IF (NUMCRK.NE.3) GO TO 98
      EPSUP=EPSU*EPSCP/EPSC
      IF (TEP(1).GT.EPSUP .AND. TEP(2).GT.EPSUP .AND. TEP(4).GT.EPSUP)
     1    GO TO 93
      DO 92 I=1,4
   92 SIGP(I)=0.
      GO TO 98
C
   93 IF (ILOCAL.EQ.1) GO TO 140
      RETURN
C
C     RELEASE APPROPRIATE STRESSES
C
   98 NF=NUMCRK + 1
      GO TO (140,120,110,155,100,100,100), NF
  100 SIGP(4)=0.
      IF (NUMCRK - 5) 140,120,110
  110 SIGP(2)=0.
  120 SIGP(3)=SIGP(3)*ETATAU
      SIGP(1)=0.
C
C     ROTATE STRESSES TO GLOBAL AXES
C
  140 DO 150 IR=1,4
      DO 150 IC=1,4
  150 DSIG(IR)=DSIG(IR) + T(IC,IR)*SIGP(IC)
C
  155 DO 160 I=1,4
  160 SIG(I)=DSIG(I)
C
      RETURN
C
      END
C *CDC* *DECK THERM2
C *UNI* )FOR,IS N.THERM2, R.THERM2
      SUBROUTINE THERM2 (NODS,NOD5,YZ,PROP,TEMPV2,EPS,TMPOLD,ITYP2D)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /GAUSS/XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),R,S,T
      COMMON /TODIM/ BET,THIC,DE,IEL,NND5
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
C
      DIMENSION NODS(1),NOD5(1),YZ(1),PROP(1),TEMPV2(1),H(8),P(2,8),
     1          XJ(2,2),IPRM(4),EPS(1)
      DATA IPRM/ 1, 1, 0, 1/
C
C     CALCULATE INITIAL STRAIN DUE TO TEMPERATURE
      IINTP=1
      CALL FUNCT2 (R,S,H,P,NOD5,XJ,DET,YZ,NEL,IINTP)
C
      TEMP2=0.
      DO 20 K=1,IEL
      KK=NODS(K)
   20 TEMP2=TEMP2 + H(K)*TEMPV2(KK)
      CTEMP=TEMP2
      DEPST=PROP(3)*(CTEMP - TMPOLD)
C
C     CALCULATE STRESS CONTRIBUTION TO BE ADDED TO NODAL FORCE VECTOR
C
      IST=4
      IF (ITYP2D .GE. 2) IST=3
      DO 50 I=1,IST
      EPS(I)=EPS(I) + IPRM(I)*DEPST
      DO 50 J=1,IST
   50 STRESS(I)=STRESS(I) - C(I,J)*IPRM(J)*DEPST
C
C     UPDATE OLD TEMPERATURE TO CURRENT TEMPERATURE
C
      TMPOLD=CTEMP
      RETURN
C
      END
C *CDC* *DECK OVL33
C *CDC*       OVERLAY (ADINA,3,3)
C *CDC* *DECK ELT2D6
C *UNI* )FOR,IS  N.ELT2D6, R.ELT2D6
C *CDC*       PROGRAM ELT2D6
      SUBROUTINE ELT2D6
C
C
C                       M O D E L   =  6
C
C
C
      RETURN
      END
C *CDC* *DECK OVL34
C *CDC*       OVERLAY (ADINA,3,4)
C *CDC* *DECK ELT2D7
C *UNI* )FOR,IS  N.ELT2D7, R.ELT2D7
C *CDC*       PROGRAM ELT2D7
      SUBROUTINE ELT2D7
C
C     M O D E L   =   7
C
C
C     E L A S T O P L A S T I C  M O D E L  (DRUCKER-PRAGER WITH
C     HARDENING CAP AND TENSION CUTOFF)
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),(A(1),IA(1))
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE TODMFE
C
C
      IDW=10*ITWO
      NPT=NINT*NINT
      MATP=IA(N107 + NEL - 1)
      NM=N109 + (MATP-1)*8*ITWO
      IF(IND.NE.0) GO TO 100
C
C     INITIALIZE WORKING ARRAY
C
      NN=N110 + (NEL-1)*NPT*IDW
C
      CALL IDRUCK(A(NN),A(NN),A(NM),NPT,IDW)
C
      GO TO 500
C
C     FIND MATERIAL LAW AND STRESSES
C
  100 NS=N110 + ((NEL-1)*NPT + (IPT-1))*IDW
      NS1=NS + 4*ITWO
      NS2=NS + 8*ITWO
      NS3=NS + 9*ITWO
      CALL DRUCK(A(NM), A(NS), A(NS1), A(NS2), A(NS3))
  500 CONTINUE
C
      RETURN
      END
C *CDC* *DECK IDRUCK
C *UNI* )FOR,IS  N.IDRUCK, R.IDRUCK
      SUBROUTINE IDRUCK(WA,IWA,PROP,NPT,IDW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /DPR/ ITWO
      DIMENSION WA(10,1),IWA(IDW,1),PROP(1)
C
      DO 25 J=1,NPT
C
C     SET INITIAL STRESSES AND STRAINS TO ZERO
C
      DO 15 I=1,8
      WA(I,J)=0.0
   15 CONTINUE
C
C     SET INITIAL CAP POSITIONS
C
      WA(9,J)=PROP(8)
C
C     SET INITIAL STRESS STATE TO ELASTIC
C
      KJ=9*ITWO + 1
      IWA(KJ,J)=1
C
   25 CONTINUE
C
      RETURN
      END
C *CDC* *DECK DRUCK
C *UNI* )FOR,IS  N.DRUCK, R.DRUCK
      SUBROUTINE DRUCK(PROP,SIG,EPS,XI1A,IPEL)
C
C
C
C
C     IST     NUMBER OF STRESS COMPONENTS
C     ISR     NUMBER OF STRAIN COMPONENTS
C     SIG     STRESSES AT END OF PREVIOUS UPDATE
C     EPS     STRAINS AT 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     STRESS  CURRENT STRESSES
C     STRAIN  CURRENT STRAINS
C     EPSP    CURRENT PLASTIC STRAINS
C     XI1A    CAP POSITION
C
C
C     PROP(1)  YOUNGS MODULUS
C     PROP(2)  POISSONS RATIO
C     PROP(3)  DRUCKER-PRAGER YIELD FUNCTION PARAMETER (ALPHA)
C     PROP(4)  DRUCKER-PRAGER YIELD FUNCTION PARAMETER (K)
C     PROP(5)  CAP HARDENING CONSTANT (W)
C     PROP(6)  CAP HARDENING CONSTANT (D)
C     PROP(7)  TENSION CUTOFF LIMIT (T)
C     PROP(8)  INITIAL CAP POSITION
C
C
C     IPEL = 1,  ELASTIC
C          = 2,  PLASTIC (DRUCKER-PRAGER)
C          = 3,  PLASTIC (SPECIAL CASE WHEN DRUCKER-PRAGER AT VERTEX)
C          = 4,  PLASTIC (VERTEX)
C          = 5,  PLASTIC (CAP)
C          = 6,  TENSION CUTOFF LIMIT
C
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 /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /DRPRAG/ A1,B1,C1,A2,B2,B3,C2,D2,G,BM,ALFA,XK,DC,WC,
     1                TCUT,A1I,B1I,C1I,ISR,IST
C
      DIMENSION PROP(1),SIG(1),EPS(1),SS(4),DSS(4)
      DIMENSION DELSIG(4),DELEPS(4),DEPS(4),STATE(2),SS1(4),TEPS(4)
      DIMENSION EPSP(4)
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(5),ITYP2D),(DELEPS(1),DEPS(1)),
     1            (SS(1),SS1(1))
      DATA STATE /2H E,2H*P/
C
C
      XI1AD=XI1A
      IPELD=IPEL
      DEPS(4)=0.0
      DELEPS(4)=0.0
      STRESS(4)=0.0
      TEPS(4)=0.0
      IF(IPT.NE.1) GO TO 110
C
C        1. CALCULATE MATERIAL CONSTANTS
C
      IST=4
      IF(ITYP2D.GE.2) IST=3
      ISR=3
      IF(ITYP2D.EQ.0) ISR=4
      YM=PROP(1)
      PV=PROP(2)
      D2=PV/(PV-1.0)
      G=YM/(1.0+PV)/2.0
      BM=YM/(1.0-2.0*PV)/3.0
      A2=BM+4.0*G/3.0
      B2=BM-2.0*G/3.0
      B3=1.0/(3.0*BM)
      C1=G
      C2=G
C
      A1I=1.0/YM
      B1I=-PV/YM
      C1I=1.0/C1
C
      IF(ITYP2D.GE.2) GO TO 105
C
C     PLANE STRAIN / AXISYMMETRIC **
C
      A1=A2
      B1=B2
      GO TO 108
C
C     PLANE STRESS **
C
  105 A1=YM/(1.0-PV*PV)
      B1=A1*PV
C
  108 ALFA=PROP(3)
      XK=PROP(4)
      WC=PROP(5)
      DC=PROP(6)
      TCUT=PROP(7)
      IF(TCUT.GE.(XK/ALFA)) TCUT=0.99*XK/ALFA
C
C        2. CALCULATE STRAIN INCREMENT, INITIALIZE TEPS(I)
C
  110 DO 120 I=1,ISR
      TEPS(I)=EPS(I)
  120 DELEPS(I)=STRAIN(I)-EPS(I)
      IF(ITYP2D.GE.2) TEPS(4)=EPS(4)
C
C        3. CALCULATE THE 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)=0.0
      IF(ITYP2D.GE.2) GO TO 150
      DELSIG(4)=B1*(DELEPS(1) + DELEPS(2))
      IF(ITYP2D.EQ.1) GO TO 150
      DELSIG(1)=DELSIG(1) + B1*DELEPS(4)
      DELSIG(2)=DELSIG(2) + B1*DELEPS(4)
      DELSIG(4)=DELSIG(4) + A1*DELEPS(4)
C
C        4. CALCULATE TOTAL STRESSES AND INVARIANTS,
C           ASSUMING ELASTIC BEHAVIOR
C
  150 DO 160 I=1,IST
  160 STRESS(I)=SIG(I) + DELSIG(I)
      CALL DEVSTR(SIG,SS1,XI11,XJ21)
      CALL DEVSTR(STRESS,DSS,XI12,XJ22)
      DXI1=XI12 - XI11
      DO 165 J=1,4
  165 DSS(J)=DSS(J) - SS1(J)
C
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      DX=DSS(1)
      DY=DSS(2)
      DXY=DSS(3)
      DZ=DSS(4)
C
C        5. CHECK IF ELASTIC STATE OF STRESS LIES
C           OUTSIDE YIELD SURFACE
C
      IF(XI12.GE.TCUT) GO TO 170
      IF(XI12.LT.XI1AD) GO TO 190
      GO TO 180
C
C     CHECK FOR TENSION CUTOFF OR DRUCKER-PRAGER YIELDING **
C
  170 IF(DXI1.EQ.0.0) GO TO 175
      FT1=(TCUT - XI11)/DXI1
      FT2=FT1*FT1
      FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + DXY*DXY
      FT4=SX*DX + SY*DY + 2.0*SXY*DXY + SZ*DZ
      FT=DSQRT(XJ21 + FT2*FT3 + FT1*FT4) + ALFA*TCUT - XK
C
      IF(FT) 175,175,176
C
C     TENSION CUTOFF *
C
  175 ICHK=6
      GO TO 210
C
C     DRUCKER-PRAGER YIELDING  *
C
  176 ICHK=2
      GO TO 210
C
C     CHECK FOR DRUCKER-PRAGER YIELDING **
C
  180 FT=ALFA*XI12 + DSQRT(XJ22) - XK
      FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + DXY*DXY
      FT4=SX*DX + SY*DY + 2.0*SXY*DXY + SZ*DZ
      IF(FT) 200,200,185
C
  185 ICHK=2
      FTOLD=ALFA*XI11 + DSQRT(XJ21) - XK
      IF(XI11.EQ.XI1AD.AND.DXI1.EQ.0.0) ICHK=3
      IF(XI11.EQ.XI1AD.AND.FTOLD.EQ.0.0) ICHK=3
      GO TO 210
C
C     CHECK FOR DRUCKER-PRAGER YIELDING, VERTEX YIELDING,
C     OR CAP YIELDING **
C
  190 FT1=(XI1AD - XI11)/DXI1
      FT2=FT1 * FT1
      FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + DXY*DXY
      FT4=SX*DX + SY*DY + 2.0*SXY*DXY + SZ*DZ
      FT=DSQRT(XJ21 + FT2*FT3 + FT1*FT4) + ALFA*XI1AD - XK
C
      IF(DABS(FT) .LE. (1.D-10*DSQRT(XJ21)))FT= 0.
      IF(FT) 192,194,196
C
C     CAP YIELDING *
C
  192 ICHK=5
      GO TO 210
C
C     VERTEX YIELDING (ADDITIONAL CHECK IS MADE LATER) *
C
  194 ICHK=3
      GO TO 210
C
C     DRUCKER-PRAGER YIELDING *
C
  196 ICHK=2
      GO TO 210
C
C     ELASTIC STRESS STATE IS WITHIN THE YIELD SURFACE AND DOES NOT
C     EXCEED TENSION CUTOFF **
C
  200 IPELD=1
      IF(ITYP2D.GE.2) TEPS(4)=EPS(4) + D2*(DELEPS(1) + DELEPS(2))
      GO TO 700
C
C        6. ELASTIC STRESS STATE LIES OUTSIDE THE YIELD
C           SURFACE OR EXCEEDS TENSION CUTOFF---ADDITIONAL
C           STRESS CALCULATIONS ARE REQUIRED
C
C     CALCULATE THE FRACTION OF THE STRAIN INCREMENT OVER WHICH
C     THE MATERIAL RESPONSE IS ELASTIC **
C
  210 GO TO (200,220,250,250,250,260), ICHK
C
C     DRUCKER-PRAGER YIELDING *
C
  220 IF(IPELD.LT.2.OR.IPELD.GT.4) GO TO 230
C
C     STRESS STATE AT TIME OF LAST UPDATE IS ON THE DRUCKER-PRAGER
C     YIELD SURFACE
C
      IPELD=2
      A=(2.0 * ALFA * XK * DXI1) - (2.0 * ALFA * ALFA * XI11 * DXI1)
     1 + FT4
      RATIO=0.0
      IF(A) 225,300,300
C
  225 RATIO=-A/(FT3 - ALFA*ALFA*DXI1*DXI1)
      GO TO 300
C
C     STRESS STATE AT TIME OF LAST UPDATE IS NOT ON THE DRUCKER-PRAGER
C     YIELD SURFACE
C
  230 IPELD=2
      A=FT3 - ALFA*ALFA*DXI1*DXI1
      IF(A) 234,232,234
C
  232 RATIO=-(XJ21 - XK*XK + 2.0*ALFA*XK*XI11 - ALFA*ALFA*XI11*XI11)
     1      /(FT4 + 2.0*ALFA*XK*DXI1 - 2.0*ALFA*ALFA*XI11*DXI1)
      GO TO 300
C
  234 B=FT4 + 2.0*ALFA*XK*DXI1 - 2.0*ALFA*ALFA*XI11*DXI1
      CC=XJ21 - XK*XK + 2.0*ALFA*XK*XI11 - ALFA*ALFA*XI11*XI11
      RATIO=(-B + DSQRT(B*B - 4.0D0*A*CC))/(2.0*A)
      IF(A.GT.0.0) GO TO 300
C
      RATIO1=RATIO
      RATIO2=(-B - DSQRT(B*B - 4.0D0*A*CC))/(2.0*A)
C
C     DETERMINE THE CORRECT VALUE TO USE FOR RATIO
C
      KEY1=0
      KEY2=0
      ICNT=0
      XLIM=TCUT
C
  235 IF(RATIO1.GE.0.0.AND.RATIO1.LE.1.0) KEY1=1
      IF(RATIO2.GE.0.0.AND.RATIO2.LE.1.0) KEY2=1
      IF((KEY1 + KEY2).GE.1) GO TO 238
      IF(ICNT.EQ.0) GO TO 236
      WRITE(6,3004)
      STOP
C
C     CHECK IF RATIO1 AND/OR RATIO2 LIE WITHIN THE TOLERANCE RANGE
C
  236 IF(DABS(RATIO1).LT.1.0D-6) RATIO1=0.0
      IF(DABS(RATIO2).LT.1.0D-6) RATIO2=0.0
      IF(DABS(RATIO1 - 1.0).LT.1.0D-6) RATIO1=1.0
      IF(DABS(RATIO2 - 1.0).LT.1.0D-6) RATIO2=1.0
C
C     RECHECK VALUES OF RATIO1 AND RATIO2
C
      ICNT=ICNT + 1
      GO TO 235
C
  238 XINT1=XI11 + RATIO1*DXI1
      XINT2=XI11 + RATIO2*DXI1
      IF(XINT1.LE.XLIM.AND.XINT1.GE.XI1AD) KEY1=KEY1 + 1
      IF(XINT2.LE.XLIM.AND.XINT2.GE.XI1AD) KEY2=KEY2 + 1
C
      IF((KEY1 + KEY2).GT.3 .OR. (KEY1 + KEY2).LT.2) GO TO 240
      IF(KEY1.EQ.1.AND.KEY2.EQ.1) GO TO 240
      GO TO 245
C
  240 WRITE(6,3005)
      STOP
C
  245 IF(KEY1.EQ.2) RATIO=RATIO1
      IF(KEY2.EQ.2) RATIO=RATIO2
      GO TO 300
C
C     VERTEX YIELDING OR CAP YIELDING *
C
  250 RATIO=(XI1AD - XI11)/DXI1
      IF(ICHK.EQ.5) IPELD=5
      GO TO 300
C
C     TENSION CUTOFF *
C
  260 IPELD=6
      CALL TENSL(TEPS,DELEPS)
      IF(ITYP2D.GE.2) TEPS(4)=EPS(4) + DELEPS(4)
      GO TO 700
C
C        7. UPDATE STRESS(I) AND TEPS(I) TO THE
C           START OF YIELDING
C
  300 DO 310 J=1,IST
  310 STRESS(J)=SIG(J) + RATIO*DELSIG(J)
C
      DO 315 J=1,ISR
  315 TEPS(J)=EPS(J) + RATIO*DELEPS(J)
      IF(ITYP2D.GE.2) TEPS(4)=EPS(4) + RATIO*D2*(DELEPS(1) + DELEPS(2))
C
C        8. DETERMINE TYPE OF VERTEX YIELDING, IF NECESSARY
C
      IF(ICHK.NE.3) GO TO 350
      IF(ITYP2D.GE.2) DELEPS(4)=D2*(DELEPS(1) + DELEPS(2))
      DVSTR=DELEPS(1) + DELEPS(2) + DELEPS(4)
      CALL DEVSTR(STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      XLMDP=ALFA*3.0*BM*DVSTR + (G/DSQRT(XJ2)) * (SX*DELEPS(1)
     1      + SY*DELEPS(2) + SXY*DELEPS(3) + SZ*DELEPS(4))
      XLMDP=XLMDP/(9.0*BM*ALFA*ALFA+G)
      XLMC=-3.0*BM*DVSTR
      XDUM=3.0*ALFA*XLMDP
C
      IF(XLMDP.GT.0.0) GO TO 325
  320 IPELD=5
      GO TO 350
  325 IF(XLMC.GT.0.0) GO TO 330
      IPELD=2
      IF(DVSTR.EQ.XDUM) IPELD=3
      GO TO 350
  330 IPELD=4
C
C        9. ELASTIC-PLASTIC STRESS CALCULATIONS
C
C     DETERMINE SUBDIVISION FOR NUMERICAL INTEGRATION OF THE
C     STRESS-STRAIN LAW **
C
  350 M=25
      XM=(1.0 - RATIO)/DBLE(FLOAT(M))
C
C     SUBDIVIDE STRAIN INCREMENT **
C
      DO 355 I=1,ISR
  355 DEPS(I)=XM*DELEPS(I)
C
C     START OF STRESS CALCULATION LOOP **
C
      DO 600 INDEX=1,M
C
C     CHECK LOCATION OF CURRENT STATE OF STRESS **
C
      GO TO (420,420,420,450,450), IPELD
C
C     DRUCKER-PRAGER (INCLUDING DRUCKER-PRAGER AT VERTEX,  IPEL=2,3) **
C
  420 CALL PRAGER(DEPS,IPELD)
C
  422 DO 425 I=1,IST
      DO 425 J=1,ISR
  425 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
C
C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
C
      CALL DEVSTR(STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      FT=ALFA*XI1 + DSQRT(XJ2) - XK
      IF(DABS(FT).LE.1.0D-6) GO TO 430
      GAMMA=(XK - ALFA*XI1)/DSQRT(XJ2)
C
      STRESS(1)=GAMMA*SX + XI1/3.0
      STRESS(2)=GAMMA*SY + XI1/3.0
      STRESS(3)=GAMMA*SXY
      STRESS(4)=GAMMA*SZ + XI1/3.0
      IF(ITYP2D.GE.2) STRESS(4)=0.0
C
      XI1=STRESS(1) + STRESS(2) + STRESS(4)
C
C     UPDATE TEPS(I) *
C
  430 DO 432 I=1,4
  432 TEPS(I)=TEPS(I) + DEPS(I)
C
C     CHECK FOR TENSION CUTOFF *
C
      IF(XI1.LT.TCUT) GO TO 435
      IPELD=6
      CALL TENSL(TEPS,DEPS)
      IF(ITYP2D.GE.2) TEPS(4)=TEPS(4) + DEPS(4)
      GO TO 700
C
C     CALCULATE VOLUMETRIC PLASTIC STRAIN  (TOTAL AND INCREMENT)
C     UPDATE CAP POSITION *
C
  435 IF(IPELD.EQ.3) GO TO 442
      CALL DEVSTR(STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      AA=(9.0*BM*ALFA*ALFA)/(9.0*BM*ALFA*ALFA + G)
      BB=(3.0*ALFA*G)/DSQRT(XJ2)/(9.0*BM*ALFA*ALFA + G)
      DVPSTR=AA*(DEPS(1) + DEPS(2) + DEPS(4)) + BB*(SX*DEPS(1) +
     1       SY*DEPS(2) + 2.0*SXY*DEPS(3) + SZ*DEPS(4))
C
      VPSTR=(TEPS(1) + TEPS(2) + TEPS(4)) - B3*(STRESS(1) + STRESS(2)
     1      + STRESS(4))
C
      XI1AD= XI1AD + (1.0/(DC*(WC - VPSTR)))*DVPSTR
C
C     CHECK CAP POSITION AND RESET, IF NECESSARY *
C
  440 IF(XI1.GE.XI1AD) GO TO 600
      IPELD=3
  442 XI1AD=XI1
      GO TO 600
C
C     VERTEX (IPEL=4) OR CAP (IPEL=5) **
C
  450 VPSTR=(TEPS(1) + TEPS(2) + TEPS(4)) - B3*(STRESS(1) + STRESS(2)
     1      + STRESS(4))
      IF (IPELD .EQ. 4) CALL VERT (DEPS,VPSTR)
      IF (IPELD .EQ. 5) CALL CAP (DEPS,VPSTR)
C
      DO 455 I=1,IST
      DO 455 J=1,ISR
  455 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
C
C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
C
      CALL DEVSTR (STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      FT=ALFA*XI1 + DSQRT(XJ2) - XK
      IF (IPELD .EQ. 5) GO TO 460
      IF (DABS(FT) .LE. 1.0D-06) GO TO 465
      GO TO 462
C
  460 IF (FT .LE. 1.0D-06) GO TO 465
C
  462 GAMMA=(XK - ALFA*XI1)/DSQRT(XJ2)
      STRESS(1)=GAMMA*SX + XI1/3.0
      STRESS(2)=GAMMA*SY + XI1/3.0
      STRESS(3)=GAMMA*SXY
      STRESS(4)=GAMMA*SZ + XI1/3.0
      XI1=STRESS(1) + STRESS(2) + STRESS(4)
C
C     UPDATE CAP POSITION *
C
  465 XI1AD=XI1
C
C     UPDATE TEPS(I) *
C
      DO 468 I=1,4
  468 TEPS(I)=TEPS(I) + DEPS(I)
C
  600 CONTINUE
C
C        10. PERMANENT UPDATING OF VARIABLES
C
  700 IF (IUPDT .NE. 0) GO TO 730
      XI1A=XI1AD
      IPEL=IPELD
      DO 710 I=1,IST
  710 SIG(I)=STRESS(I)
      DO 720 I=1,ISR
  720 EPS(I)=STRAIN(I)
      IF (ITYP2D .GE. 2) EPS(4)=TEPS(4)
C
C        11. CHECK FOR PRINTING OR EQUILIBRIUM ITERATION
C
  730 IF (KPRI .EQ. 0) GO TO 800
C
      IF (ICOUNT .EQ. 3) RETURN
C
C        12. FORM NEW MATERIAL LAW
C
      IF(IEQREF.EQ.1) GO TO 740
      GO TO (740,750,750,760,770,740),IPELD
C
C     ELASTIC (IPEL=1) OR TENSION CUTOFF(IPEL=6) **
C
  740 DO 745 I=1,ISR
      DO 745 J=1,ISR
  745 C(I,J)=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
      IF (ITYP2D .GE. 2) GO TO 748
      C(1,4)=B1
      C(2,4)=B1
      C(4,1)=B1
      C(4,2)=B1
      C(4,4)=A1
C
      RETURN
C
  748 C(4,1)=B2
      C(4,2)=B2
      C(4,3)=0.
      C(4,4)=A2
C
      RETURN
C
C     DRUCKER-PRAGER (INCLUDING DRUCKER-PRAGER AT VERTEX, IPEL=2,3) **
C
  750 CALL PRAGER (DEPS,IPELD)
C
      RETURN
C
C     VERTEX (IPEL=4) **
C
  760 VPSTR=(TEPS(1) + TEPS(2) + TEPS(4)) - B3*(STRESS(1) +
     1      STRESS(2) + STRESS(4))
      CALL VERT (DEPS,VPSTR)
C
      RETURN
C
C     CAP (IPEL=5) **
C
  770 VPSTR=(TEPS(1) + TEPS(2) + TEPS(4)) - B3*(STRESS(1) +
     1      STRESS(2) + STRESS(4))
      CALL CAP(DEPS,VPSTR)
C
      RETURN
C
C        13. PRINTING OF STRESSES AND STRAINS
C
  800 CALL DEVSTR (STRESS,SS,XI1,XJ2)
      IF(ITYP2D.GE.2) STRAIN(4)=TEPS(4)
      FT=ALFA*XI1 + DSQRT(XJ2) -XK
C
C     CALCULATE PLASTIC STRAINS **
C
C     PLANE STRESS *
C
      EPSP(1)=STRAIN(1) - (A1I*STRESS(1) + B1I* STRESS(2))
      EPSP(2)=STRAIN(2) - (B1I*STRESS(1) + A1I*STRESS(2))
      EPSP(3)=STRAIN(3) - C1I*STRESS(3)
      EPSP(4)=STRAIN(4) - B1I*(STRESS(1) + STRESS(2))
C
      IF (ITYP2D.GE.2) GO TO 810
C
C     PLANE STRAIN/AXISYMMETRIC *
C
      EPSP(1)=EPSP(1) - B1I*STRESS(4)
      EPSP(2)=EPSP(2) - B1I*STRESS(4)
      EPSP(4)=EPSP(4) - A1I*STRESS(4)
C
  810 IF (IPRI.NE.0) RETURN
C
      CALL MAXMIN (STRESS,SX,SY,SM)
      IDUM=1
      IF (IPELD.GT.1 .AND. IPELD.LT.6) IDUM=2
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(IDUM),STRESS(4),(STRESS(J),J=1,3),
     1               SX,SY,SM
      WRITE (6,2200) IPELD,XI1AD,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(IDUM),STRESS(4),(STRESS(J),J=1,3),
     1               SX,SY,SM
      WRITE (6,2400) STRAIN(4),(STRAIN(J),J=1,3)
      WRITE (6,2500) EPSP(4),(EPSP(J),J=1,3)
      WRITE (6,2200) IPELD,XI1AD,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 (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,6(E14.6,1X),F6.2)
 2200 FORMAT (20X,7HIPEL = ,I2,2X,15HCAP POSITION = ,E14.6,2X,
     1        21HD-P YIELD FUNCTION = ,E14.6,/)
 2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,4(E14.6,1X))
 2500 FORMAT (25X,7HPLASTIC,3X,4(E14.6,1X))
C
 3004 FORMAT(86H   ERROR   UNABLE TO OBTAIN VALUE FOR "RATIO" BETWEEN 0.
     10 AND 1.0   (SUBROUTINE DRUCK)/)
 3005 FORMAT(74H   ERROR   UNABLE TO OBTAIN CORRECT VALUE FOR "RATIO"
     1(SUBROUTINE DRUCK)/)
      END
C *CDC* *DECK PRAGER
C *UNI* )FOR,IS  N.PRAGER, R.PRAGER
      SUBROUTINE PRAGER (DEPS,IPELD)
C
C     THIS SUBROUTINE FORMS THE ELASTO-PLASTIC MATERIAL LAW
C        FOR THE DRUCKER-PRAGER YIELD SURFACE (IPEL=2,3)
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 /DRPRAG/ A1,B1,C1,A2,B2,B3,C2,D2,G,BM,ALFA,XK,DC,WC,
     1                TCUT,A1I,B1I,C1I,ISR,IST
C
      DIMENSION DP(16),SS(4),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),DP(1))
C
C
      CALL DEVSTR (STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      QDQ=DSQRT (G + 9.0D0*BM*ALFA*ALFA)
      AA=G/DSQRT(XJ2)/QDQ
      BB=3.0*BM*ALFA/QDQ
C
      SA=AA*SX + BB
      SB=AA*SY + BB
      SC=AA*SXY
      SD=AA*SZ + BB
      IF (ITYP2D-1) 20,20,10
C
   10 DP1=B2 - SA*SD
      DP2=B2 - SB*SD
      DP3=   - SC*SD
      DP4=A2 - SD*SD
C
      DEPS(4)=(-DP1*DEPS(1) - DP2*DEPS(2) - DP3*DEPS(3))/DP4
C
   20 DLAMDA=BB*(DEPS(1) + DEPS(2) + DEPS(4)) +
     1       AA*(SX*DEPS(1) + SY*DEPS(2) + SXY*DEPS(3) + SZ*DEPS(4))
      IF (DLAMDA .GT. 0.0) GO TO 30
C
   25 SX=0.0
      SY=0.0
      SXY=0.0
      SZ=0.0
      IF (ITYP2D .GE. 2) DEPS(4)=D2*(DEPS(1) + DEPS(2))
      GO TO 40
C
   30 IF (IPELD .NE. 3) GO TO 35
      QDQ=DSQRT(G)
      AA=G/DSQRT(XJ2)/QDQ
      SA=AA*SX
      SB=AA*SY
      SC=AA*SXY
      SD=AA*SZ
C
      IF (ITYP2D .LT. 2) GO TO 35
      DP1=B2 - SA*SD
      DP2=B2 - SB*SD
      DP3=   - SC*SD
      DP4=A2 - SD*SD
      DEPS(4)=(-DP1*DEPS(1) - DP2*DEPS(2) - DP3*DEPS(3))/DP4
C
   35 SX=SA
      SY=SB
      SXY=SC
      SZ=SD
C
   40 DP( 1)= A2 - SX*SX
      DP( 2)= B2 - SX*SY
      DP( 3)=    - SX*SXY
      DP( 4)= B2 - SX*SZ
      DP( 5)= DP(2)
      DP( 6)= A2 - SY*SY
      DP( 7)=    - SY*SXY
      DP( 8)= B2 - SY*SZ
      DP( 9)= DP(3)
      DP(10)= DP(7)
      DP(11)=G - SXY*SXY
      DP(12)=    - SXY*SZ
C
      IF (ITYP2D .EQ. 1) RETURN
C
      DP(13)= DP(4)
      DP(14)= DP(8)
      DP(15)= DP(12)
      DP(16)= A2 - SZ*SZ
C
      IF (ITYP2D .EQ. 0) RETURN
C
C     MODIFY DP MATRIX FOR PLANE STRESS
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)
C
C
      RETURN
      END
C *CDC* *DECK VERT
C *UNI* )FOR,IS  N.VERT, R.VERT
      SUBROUTINE VERT (DEPS,VPSTR)
C
C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
C     FOR THE DRUCKER-PRAGER   CAP INTERSECTION (VERTEX,IPEL=4)
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 /DRPRAG/ A1,B1,C1,A2,B2,B3,C2,D2,G,BM,ALFA,XK,DC,WC,
     1                TCUT,A1I,B1I,C1I,ISR,IST
C
      DIMENSION VP(16),SS(4),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),VP(1))
C
C
      CALL DEVSTR (STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SXY=SS(3)
      SZ=SS(4)
      QDQ=DSQRT(G + 9.0D0*BM*ALFA*ALFA)
      AA=G/DSQRT(XJ2)/QDQ
      BB=3.0*BM*ALFA/QDQ
      CC=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC - VPSTR)))
C
      SA=AA*SX + BB
      SB=AA*SY + BB
      SC=AA*SXY
      SD=AA*SZ + BB
      IF (ITYP2D - 1) 20,20,10
C
   10 VP1=B2 - SA*SD
      VP2=B2 - SB*SD
      VP3=   - SC*SD
      VP4=A2 - SD*SD
C
      DEPS(4)=-((VP1-CC)*DEPS(1) + (VP2-CC)*DEPS(2) + VP3*DEPS(3))/
     1         (VP4-CC)
C
   20 DLAMD=BB*(DEPS(1) + DEPS(2) + DEPS(4)) +
     1      AA*(SX*DEPS(1) + SY*DEPS(2) + SXY*DEPS(3) + SZ*DEPS(4))
      DLAMC=-DEPS(1) -DEPS(2) - DEPS(4)
      IF (DLAMD .GT. 0.0 .AND. DLAMC .GT. 0.0) GO TO 30
C
      CC=0.0
      SX=0.0
      SY=0.0
      SXY=0.0
      SZ=0.0
      IF (ITYP2D .GE. 2) DEPS(4)=D2*(DEPS(1) + DEPS(2))
C
   30 VP(1)=A2 - SX*SX - CC
      VP(2)=B2 - SX*SY - CC
      VP(3)=-SX*SXY
      VP(4)=B2 - SX*SZ - CC
      VP(5)=VP(2)
      VP(6)=A2 - SY*SY - CC
      VP(7)=-SY*SXY
      VP(8)=B2 - SY*SZ - CC
      VP(9)=VP(3)
      VP(10)=VP(7)
      VP(11)=G - SXY*SXY
      VP(12)=-SXY*SZ
C
      IF (ITYP2D .EQ. 1) RETURN
C
      VP(13)=VP(4)
      VP(14)=VP(8)
      VP(15)=VP(12)
      VP(16)=A2 - SZ*SZ - CC
C
      IF (ITYP2D .EQ. 0) RETURN
C
C     MODIFY VP MATRIX FOR PLANE STRESS
C
      DO 100 I=1,3
      A=C(I,4)/C(4,4)
      DO 100 J=I,3
      C(I,J)=C(I,J) - C(4,J)*A
  100 C(J,I)=C(I,J)
C
C
      RETURN
      END
C *CDC* *DECK CAP
C *UNI* )FOR,IS  N.CAP, R.CAP
      SUBROUTINE CAP (DEPS,VPSTR)
C
C        THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
C        FOR THE 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 /DRPRAG/ A1,B1,C1,A2,B2,B3,C2,D2,G,BM,ALFA,XK,DC,WC,
     1                TCUT,A1I,B1I,C1I,ISR,IST
C
      DIMENSION CP(16),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D),(C(1,1),CP(1))
C
C
C
C
      GAMMA=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC-VPSTR)))
C
      CP1=A2 - GAMMA
      CP2= B2 - GAMMA
      IF (ITYP2D-1) 15,15,10
   10 DEPS(4)=-(CP2/CP1)*(DEPS(1) + DEPS(2))
C
   15 DLAMDA=-DEPS(1) - DEPS(2) - DEPS(4)
      IF (DLAMDA .GT. 0.0) GO TO 20
      IF (ITYP2D .GE. 2) DEPS(4)=D2*(DEPS(1) + DEPS(2))
      CP1=A2
      CP2=B2
   20 CP(1)=CP1
      CP(2)=CP2
      CP(3)=0.0
      CP(4)=CP(2)
      CP(5)=CP(2)
      CP(6)=CP(1)
      CP(7)=0.0
      CP(8)=CP(2)
      CP(9)=0.0
      CP(10)=0.0
      CP(11)=G
      CP(12)=0.0
C
      IF (ITYP2D .EQ. 1) RETURN
C
      CP(13)=CP(2)
      CP(14)=CP(2)
      CP(15)=0.0
      CP(16)=CP(1)
C
      IF (ITYP2D .EQ. 0) RETURN
C
C     CONDENSE C(I,J) FOR PLANE STRESS
C
      DO 50 I=1,3
      A=C(I,4)/C(4,4)
      DO 50 J=I,3
      C(I,J)=C(I,J) - C(4,J)*A
   50 C(J,I)=C(I,J)
C
C
      RETURN
      END
C *CDC* *DECK DEVSTR
C *UNI* )FOR,IS  N.DEVSTR, R.DEVSTR
      SUBROUTINE DEVSTR (STRESS,DSTRS,XI1,XJ2)
C
C
C     THIS SUBROUTINE CALCULATES THE FOLLOWING QUANTITIES -
C          1. DEVIATORIC STRESS TENSOR
C          2. ITS SECOND INVARIANT
C          3. FIRST INVARIANT OF THE STRESS TENSOR
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION STRESS(4),DSTRS(4)
C
C
      SM=STRESS(1) + STRESS(2) + STRESS(4)
      XI1=SM
      SM=SM/3.
C
      DSTRS(1)=STRESS(1) - SM
      DSTRS(2)=STRESS(2) - SM
      DSTRS(3)=STRESS(3)
      DSTRS(4)=STRESS(4) - SM
C
      XJ2=0.5*(DSTRS(1)*DSTRS(1) + DSTRS(2)*DSTRS(2) +
     1    DSTRS(4)*DSTRS(4)) + (DSTRS(3)*DSTRS(3))
C
      RETURN
      END
C *CDC* *DECK TENSL
C *UNI* )FOR,IS  N.TENSL, R.TENSL
      SUBROUTINE TENSL (TEPS,DEPS)
C
C     THIS SUBROUTINE PERFORMS THE STRESS CALCULATIONS
C     REQUIRED WHEN THE TENSION CUTOFF LIMIT IS EXCEEDED (IPEL=6)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /DRPRAG/ A1,B1,C1,A2,B2,B3,C2,D2,G,BM,ALFA,XK,DC,WC,
     1                TCUT,A1I,B1I,C1I,ISR,IST
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      DIMENSION TEPS(1),DEPS(1)
      EQUIVALENCE (NPAR(5),ITYP2D)
C
C
      IF (ITYP2D .GE. 2) GO TO 50
      STRESS(1)=TCUT/3.0
      STRESS(2)=TCUT/3.0
      STRESS(3)=0.0
      STRESS(4)=TCUT/3.0
      RETURN
C
   50 SIG1=STRESS(1)
      SIG2=STRESS(2)
      STRESS(1)=TCUT/2.0
      STRESS(2)=TCUT/2.0
      STRESS(3)=0.0
      STRESS(4)=0.0
      DEPS(4)=-(STRAIN(1) - TEPS(1) + STRAIN(2) - TEPS(2)) +
     1         (TCUT - SIG1 - SIG2)/(3.0*BM)
C
      RETURN
      END
C *CDC* *DECK OVL35
C *CDC*       OVERLAY (ADINA,3,5)
C *CDC* *DECK ELT2D8
C *UNI* )FOR,IS  N.ELT2D8, R.ELT2D8
C *CDC*       PROGRAM ELT2D8
      SUBROUTINE ELT2D8
C
C
C                       M O D E L S  =  8 AND 9
C
C     E L A S T I C - P L A S T I C   M O D E L   (VON MISES)
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 /DPR/ ITWO
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(17),NCON)
      EQUIVALENCE (A(1),IA(1))
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE TODMFE
C
      IDW=15*ITWO
      NPT=NINT*NINT
      MATP=IA(N107 + NEL - 1)
      NM=N109 + (MATP - 1)*NCON*ITWO
      IF (IND.NE.0) GO TO 100
C
C
C     I N I T I A L I Z E  W A   W O R K I N G   A R R A Y
C
C
      NN=N110 + (NEL - 1)*NPT*IDW
      CALL IELPAL (A(NN),A(NN),A(NM),NPT,IDW)
      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 NN=N110 + (NEL - 1)*NPT*IDW + (IPT - 1)*IDW
C
      CALL ELPAL (A(NM),A(NN),A(NN + 4*ITWO),A(NN + 8*ITWO),
     1            A(NN + 12*ITWO),A(NN + 13*ITWO),A(NN + 14*ITWO))
  599 CONTINUE
      RETURN
C
C
      END
C *CDC* *DECK IELPAL
C *UNI* )FOR,IS  N.IELPAL, R.IELPAL
      SUBROUTINE IELPAL (WA,IWA,PROP,NPT,IDW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DPR/ ITWO
      DIMENSION WA(15,1),IWA(IDW,1),PROP(1)
C
C     SET INITIAL STRESSES AND STRAINS TO ZERO
C     SET INITIAL STRESS STATE TO *ELASTIC*
C
      DO 10 J=1,NPT
      DO 15 I=1,13
   15 WA(I,J)=0.0
      WA(14,J)=(PROP(3)**2)/3.0
      KJ=14*ITWO + 1
   10 IWA(KJ,J)=1
C
      RETURN
      END
C *CDC* *DECK ELPAL
C *UNI* )FOR,IS  N.ELPAL,  R.ELPAL
      SUBROUTINE ELPAL (PROP,SIG,EPS,ALFA,EPSTR,YIELD,IPEL)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   THIS SUBROUTINE CALCULATES THE STRESSES AND STRESS-STRAIN LAW   .
C .   FOR THE FOLLOWING 2-DIM MATERIAL MODELS -                       .
C .                                                                   .
C .      MODEL=8  (MOD=2)    ELASTIC-PLASTIC WITH ISOTROPIC HARDENING .
C .      MODEL=9  (MOD=1)    ELASTIC-PLASTIC WITH KINEMATIC HARDENING .
C .                                                                   .
C .      ELASTIC-PERFECTLY PLASTIC CAN BE HANDLED WITH EITHER MODEL   .
C .      BY SETTING THE HARDENING MODULUS TO ZERO.                    .
C .      HOWEVER, IF THE CALCULATED STRESSES FALL BEYOND THE TOLERATED.
C .      VALUE, MODEL=8 WILL APPLY A CORRECTION WHEREAS MODEL=9 WILL  .
C .      WILL NOT APPLY SUCH A CORRECTION.                            .
C .                                                                   .
C .   THE FOLLOWING VARIABLES ARE USED IN THIS SUBROUTINE -           .
C .                                                                   .
C .      IST     NUMBER OF STRESS COMPONENTS                          .
C .      ISR     NUMBER OF STRAIN COMPONENTS                          .
C .      SIG     STRESSES AT THE END OF THE PREVIOUS UPDATE           .
C .      EPS     STRAINS  AT THE END OF THE PREVIOUS UPDATE           .
C .      STRAIN  CURRENT TOTAL STRAINS                                .
C .              (TOTAL STRAIN INCREMENT IN ULJ FORMULATION)          .
C .      STRESS  CURRENT STRESSES                                     .
C .      EPSP    CURRENT PLASTIC STRAINS                              .
C .      EPSTR   ACCUMULATED EFFECTIVE PLASTIC STRAIN                 .
C .      RATIO   PART OF STRAIN INCREMENT TAKEN ELASTICALLY           .
C .      DELEPS  INCREMENT IN STRAINS                                 .
C .      DELSIG  INCREMENT IN STRESSES, ASSUMING ELASTIC BEHAVIOR     .
C .                                                                   .
C .      PROP(1) YOUNG S  MODULUS                                     .
C .      PROP(2) POISSON S  RATIO                                     .
C .                                                                   .
C .      BILINEAR STRESS-STRAIN CURVE                                 .
C .                                                                   .
C .      PROP(3) INITIAL YIELD STRESS IN SIMPLE TENSION               .
C .      PROP(4) STRAIN HARDENING MODULUS                             .
C .                                                                   .
C .      PIECEWISE-LINEAR STRESS-STRAIN CURVE                         .
C .                                                                   .
C .      PROP(3),PROP(4),...,PROP(NCON - 1),PROP(NCON) ARE THE        .
C .      PAIRS OF STRESS, STRAIN VALUES DEFINING THE PLASTIC          .
C .      PORTION OF THE STRESS-STRAIN CURVE (PROP(3) IS THE INITIAL   .
C .      YIELD STRESS IN SIMPLE TENSION)                              .
C .                                                                   .
C .      IPEL    = 1, MATERIAL ELASTIC                                .
C .              = 2, MATERIAL PLASTIC                                .
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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /VMISES/ A1,B1,C1,D1,A2,B2,C2,A3,BM,BET,CEE,
     1                DEPS(4),DEPSP(4),TEPS(4),ALFAD(4),HP,FTB,A1I,B1I,
     2                C1I,XCON1,XCON2,MOD,ISR,IST
      COMMON /PSTCH/ STRCH(3),RDCS(3)
      COMMON /MATMOD/ STRESS(4),STRAIN(4),C(4,4),IPT,NEL,IPS
      COMMON /DISDER/ DISD(5)
      COMMON /TODIM/ BETA,THIC,DE,IEL,NND5
C
      DIMENSION PROP(1),SIG(1),EPS(1),ALFA(1),EPSP(4)
      DIMENSION DELSIG(4),DELEPS(4),IMODEL(2),STATE(2)
C
      EQUIVALENCE (NPAR(17),NCON)
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(5),ITYP2D),(NPAR(15),MODEL)
C
      DATA IMODEL /2,1/, STATE /2H E,2H*P/, NGLAST /1000/
C
C
C
      YIELDD=YIELD
      IPELD=IPEL
      EPSTRD=EPSTR
      STRESS(4)=0.
      DELSIG(4)=0.
      DELEPS(4)=0.
C
      DO 50 I=1,4
      EPSP(I)=0.0
   50 ALFAD(I)=ALFA(I)
C
      MOD=IMODEL(MODEL - 7)
      YM=PROP(1)
      PV=PROP(2)
      ET=PROP(4)
      ETOLD=ET
C
      IF (IPT.NE.1) GO TO 80
C
      XCON1=2.0/3.0
      XCON2=1.0/3.0
C
      IST=4
      IF (ITYP2D .GE. 2) IST=3
      ISR=3
      IF (ITYP2D.EQ.0) ISR=4
C
      A2=YM/(1.+PV)
      A3=A2
      C2=A2/2.
      A2=A2/(1.-2.*PV)
      B2=A2*PV
      A2=A2-B2
      C1=C2
C
      A1I=1.0/YM
      B1I=-PV/YM
      C1I=1.0/C1
C
C
      IF (ITYP2D.GE.2) GO TO 70
C
C     PLANE STRAIN  /  AXISYMMETRIC
      A1=A2
      B1=B2
      GO TO 80
C
C     PLANE STRESS
   70 A1=YM/(1. - PV*PV)
      B1=A1*PV
      D1=PV/(PV-1.)
      BM=YM/(1.-2.*PV)/3.
C
   80 IF (NCON.GE.6) GO TO 90
C
C     BILINEAR STRESS-STRAIN CURVE
C
      IF (IPT.NE.1) GO TO 85
C
      EET=YM*ET/(YM - ET)
      CEE=XCON1*EET
      HP=(A3*A3)/(CEE + A3)/2.
      FTB=YIELDD
      BET=HP/YIELDD
      GO TO 115
C
   85 IF (ET.EQ.0.0) GO TO 115
      FTB=YIELDD
      BET=HP/YIELDD
      GO TO 115
C
C     PIECEWISE-LINEAR STRESS-STRAIN CURVE
C
   90 CALL HARDM2 (PROP,EPSTRD,ET)
      EET=YM*ET/(YM - ET)
      CEE=XCON1*EET
      HP=(A3*A3)/(CEE + A3)/2.
      FTB=YIELDD
      BET=HP/YIELDD
C
C
C        1. CALCULATE INCREMENTAL TOTAL STRAINS AND CURRENT
C           PLASTIC STRAINS
C
  115 IF (INDNL.EQ.3) GO TO 121
      DO 120 I=1,ISR
  120 DELEPS(I) = STRAIN(I) - EPS(I)
      GO TO 130
C
  121 DO 122 I=1,ISR
  122 DELEPS(I)=STRAIN(I)
      GO TO 145
C
C     PLANE STRESS
C
  130 EPSP(1)=EPS(1) - (A1I*SIG(1) + B1I*SIG(2))
      EPSP(2)=EPS(2) - (B1I*SIG(1) + A1I*SIG(2))
      EPSP(3)=EPS(3) - C1I*SIG(3)
      EPSP(4)=EPS(4) - B1I*(SIG(1) + SIG(2))
C
      IF (ITYP2D.GE.2) GO TO 145
C
C     PLANE STRAIN/AXISYMMETRIC
C
      EPSP(1)=EPSP(1) - B1I*SIG(4)
      EPSP(2)=EPSP(2) - B1I*SIG(4)
      EPSP(4)=EPSP(4) - A1I*SIG(4)
C
C
C        2. CALCULATE THE STRESS INCREMENT,
C           ASSUMING ELASTIC BEHAVIOR
C
  145 DELSIG(1)=A1*DELEPS(1) + B1*DELEPS(2)
      DELSIG(2) = B1*DELEPS(1) + A1*DELEPS(2)
      DELSIG(3) = C1*DELEPS(3)
      IF (ITYP2D .GE. 2) GO TO 150
      DELSIG(4) = B1 * (DELEPS(1)+DELEPS(2))
      IF (ITYP2D.EQ.1) GO TO 150
      DELSIG(1) = DELSIG(1) + B1*DELEPS(4)
      DELSIG(2) = DELSIG(2) + B1*DELEPS(4)
      DELSIG(4) = DELSIG(4) + A1*DELEPS(4)
C
C
C        3. WITH THE ASSUMPTION OF ELASTIC BEHAVIOR DURING
C           THIS INCREMENT, DETERMINE WHERE THE NEW STATE
C           OF STRESS FALLS IN THE STRESS SPACE
C
  150 DM=(DELSIG(1)+DELSIG(2)+DELSIG(4))/3.
      DX=DELSIG(1) - DM
      DY=DELSIG(2) - DM
      DZ=DELSIG(4) - DM
C
      SM=(SIG(1)+SIG(2)+SIG(4))/3.
      SX=SIG(1) - SM
      SY=SIG(2) - SM
      SZ=SIG(4) - SM
      SS=SIG(3)
C
      IF (MOD.EQ.2) GO TO 155
C
      SX=SX - ALFAD(1)
      SY=SY - ALFAD(2)
      SZ=SZ - ALFAD(4)
      SS=SS - ALFAD(3)
C
  155 RA=.5 * (DX**2 + DY**2 + DZ**2) + DELSIG(3)**2
      RB=SX*DX + SY*DY + SZ*DZ + 2.*SS*DELSIG(3)
      RD=FTB
      IF (IPELD.EQ.2) GO TO 160
      RD=.5 * (SX**2 + SY**2 + SZ**2) + SS**2
C
  160 FTA=RA + RB + RD
      IF (RA .EQ. 0.0) GO TO 175
      IF (FTA-FTB) 170,170,300
C
C     STATE OF STRESS WITHIN LOADING SURFACE  -  ELASTIC BEHAVIOR
C
  170 IPELD=1
C
  175 DO 176 I=1,IST
  176 STRESS(I)=SIG(I) + DELSIG(I)
      IF (ITYP2D.GE.2) STRAIN(4)=EPS(4) + D1*(DELEPS(1) + DELEPS(2))
C
      GO TO 520
C
C
C     STATE OF STRESS OUTSIDE LOADING SURFACE  -  PLASTIC BEHAVIOR
C
C
C     DETERMINE PART OF STRAIN TAKEN ELASTICLY
C
  300 IPELD=2
C
      RC=RD - FTB
      RATIO= (-RB + DSQRT(RB**2 - 4.*RA*RC)) / (2.*RA)
      DO 320 I=1,IST
  320 STRESS(I)=SIG(I) + RATIO*DELSIG(I)
C
      IF (ITYP2D.GE.2) STRAIN(4)=EPS(4) +
     1                           RATIO*D1*(DELEPS(1)+DELEPS(2))
C
C
C        5. CALCULATE PLASTIC STRESSES
C
C     DETERMINE INCREMENT INTERVAL
C
  330 INTER=20. * ( DSQRT(FTA/FTB) - 1. ) + 1.
      IF (INTER .GT. 25) INTER=25
      XM=(1. - RATIO)/DBLE(FLOAT(INTER))
C
      DO 380 I=1,ISR
  380 DEPS(I) = XM*DELEPS(I)
C
C
C     .....  CALCULATION OF ELASTOPLASTIC STRESSES  .....  (START)
C
      DO 550 IN=1,INTER
C
      CALL MIDEP
C
      DO 420 I=1,IST
      DO 420 J=1,ISR
  420 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
C
C     UPDATE PLASTIC STRAINS AND ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
      DO 425 I=1,4
  425 EPSP(I)=EPSP(I) + DEPSP(I)
C
      DEPSTR=DSQRT(XCON1*(DEPSP(1)*DEPSP(1) + DEPSP(2)*DEPSP(2) +
     1            DEPSP(4)*DEPSP(4)) + XCON2*(DEPSP(3)*DEPSP(3)))
C
      EPSTRD=EPSTRD + DEPSTR
C
      IF (MOD.EQ.2) GO TO 440
C
C     FOR KINEMATIC HARDENING, UPDATE ALFAD(I)
C
      ALFAD(1)=ALFAD(1) + CEE*DEPSP(1)
      ALFAD(2)=ALFAD(2) + CEE*DEPSP(2)
      ALFAD(4)=ALFAD(4) + CEE*DEPSP(4)
      ALFAD(3)=ALFAD(3) + 0.5*CEE*DEPSP(3)
C
      GO TO 500
C
C
  440 SM=(STRESS(1)+STRESS(2)+STRESS(4))/3.
      SX=STRESS(1) - SM
      SY=STRESS(2) - SM
      SZ=STRESS(4) - SM
C
      FTA=.5 * (SX**2 + SY**2 + SZ**2) + STRESS(3)**2
      IF (ET.NE.0.0) GO TO 500
C
C     PERFECT PLASTICITY  -  APPLY CORRECTION (IF NECESSARY)
C
  480 FTR=DSQRT(FTA/FTB)
C
C     CORRECTION
C
      IF (ITYP2D.GE.2) GO TO 490
C
      COEF= -1. + (1./FTR)
      STRESS(1)=STRESS(1) + COEF*SX
      STRESS(2)=STRESS(2) + COEF*SY
      STRESS(4)=STRESS(4) + COEF*SZ
      STRESS(3)=STRESS(3) + COEF*STRESS(3)
      GO TO 500
C
  490 COEF=1./FTR
      STRESS(1)=STRESS(1)*COEF
      STRESS(2)=STRESS(2)*COEF
      STRESS(3)=STRESS(3)*COEF
      STRAIN(4)=STRAIN(4) + (COEF - 1.)*SM/BM
C
C     UPDATE HARDENING MODULUS
C
  500 IF (NCON.GE.6) GO TO 510
C
C     BILINEAR STRESS-STRAIN CURVE
C
      IF(MOD.EQ.1) GO TO 550
      IF (ET.NE.0.0) BET=HP/FTA
      GO TO 550
C
C     PIECEWISE-LINEAR STRESS-STRAIN CURVE
C
  510 ETOLD=ET
      CALL HARDM2 (PROP,EPSTRD,ET)
      EET=YM*ET/(YM - ET)
      CEE=XCON1*EET
      HP=(A3*A3)/(CEE + A3)/2.
C
      IF (MOD.EQ.2) GO TO 530
C
      BET=HP/FTB
      GO TO 550
C
  530 BET=HP/FTA
      IF (ETOLD.EQ.0.0) BET=HP/FTB
      IF (ETOLD.NE.0.0 .AND. ET.EQ.0.0) FTB=FTA
C
  550 CONTINUE
C
C
C     .....  CALCULATION OF ELASTOPLASTIC STRESSES  .....  ( END )
C
      IF (MOD.EQ.1) GO TO 520
      IF (ETOLD.NE.0.0) YIELDD=FTA
      IF (NCON.GE.6 .AND. ETOLD.EQ.0.0) YIELDD=FTB
C
C     STRESS ROTATION IS APPLIED IN LARGE DISPLACEMENT/STRAIN
C     (U.L.J.) FORMULATION
C
  520 IF (INDNL.NE.3) GO TO 600
      SM=(STRESS(1)+STRESS(2)+STRESS(4))/3.
      SX=STRESS(1)-SM
      SY=STRESS(2)-SM
      SZ=STRESS(4)-SM
      FTA=.5*(SX*SX+SY*SY+SZ*SZ)+STRESS(3)*STRESS(3)
      OMEGA=.5*(DISD(3)-DISD(4))
      COM=DCOS(OMEGA)
      SOM=DSIN(OMEGA)
      CS2=COM*COM
      S2=SOM*SOM
      SC=SOM*COM
      ST1=STRESS(1)
      ST2=STRESS(2)
      ST3=STRESS(3)
      STRESS(1)=CS2*ST1+S2*ST2+2.*SC*ST3
      STRESS(2)=S2*ST1+CS2*ST2-2.*SC*ST3
      STRESS(3)=-SC*ST1+SC*ST2+CS2*ST3-S2*ST3
      SM=(STRESS(1)+STRESS(2)+STRESS(4))/3.
      SX=STRESS(1)-SM
      SY=STRESS(2)-SM
      SZ=STRESS(4)-SM
      FTMP=.5*(SX*SX+SY*SY+SZ*SZ)+STRESS(3)*STRESS(3)
      IF(FTMP.LE.FTA)GO TO 600
      CORR=1.
C
C     THIS STATEMENT ENSURES THAT ROUNDOFF ERROR IS ON
C     THE INSIDE OF THE YIELD SURFACE
C
      IF(FTMP.NE.0.)CORR=DSQRT(FTA/FTMP)*(1.-1.D-12)
      STRESS(1)=CORR*STRESS(1)
      STRESS(2)=CORR*STRESS(2)
      STRESS(3)=CORR*STRESS(3)
      STRESS(4)=CORR*STRESS(4)
C
C
C        6. UPDATING STRESSES, STRAINS, YIELD,IPEL
C
  600 IF (IUPDT.NE.0) GO TO 621
      YIELD=YIELDD
      IPEL=IPELD
      EPSTR=EPSTRD
      DO 610 I=1,4
      SIG(I)=STRESS(I)
      EPS(I)=STRAIN(I)
  610 ALFA(I)=ALFAD(I)
  621 IF (KPRI.EQ.0) GO TO 700
C
C
      IF (ICOUNT.EQ.3) RETURN
C
C        7. FORM THE MATERIAL LAW
C
C
C     IN DIVERGENCE REFORMATION (IEQREF=1), ASSUME ELASTIC BEHAVIOR
C
      IF (IEQREF.EQ.1) GO TO 623
      IF (IPELD.EQ.2) GO TO 650
C
  623 DO 625 I=1,ISR
      DO 625 J=1,ISR
  625 C(I,J)=0.
C
      C(1,1)=A1
      C(2,1)=B1
      C(1,2)=B1
      C(2,2)=A1
      C(3,3)=C1
C
      IF (ITYP2D-1) 635,630,640
C
  630 RETURN
C
  635 C(1,4)=B1
      C(2,4)=B1
      C(4,1)=B1
      C(4,2)=B1
      C(4,4)=A1
C
      RETURN
C
  640 C(4,1)=B2
      C(4,2)=B2
      C(4,3)=0.
      C(4,4)=A2
C
      RETURN
C
C
  650 CALL MIDEP
C
      RETURN
C
C
C     P R I N T I N G   O F   S T R E S S E S
C
  700 DM=(STRESS(1)+STRESS(2)+STRESS(4))/3.
      DX=STRESS(1) - DM
      DY=STRESS(2) - DM
      DS=STRESS(3)
      DZ=STRESS(4) - DM
C
      IF (MOD.EQ.2) GO TO 710
      DX=DX - ALFAD(1)
      DY=DY - ALFAD(2)
      DS=DS - ALFAD(3)
      DZ=DZ - ALFAD(4)
C
  710 FTA=.5 * (DX*DX + DY*DY + DZ*DZ) + DS*DS
      YIELDD=DSQRT(3.0*YIELDD)
      FT=DSQRT(3.*FTA)
C
      IF (INDNL.NE.2) GO TO 800
C
C     IN TOTAL LAGRANGIAN FORMULATION,
C     CAUCHY STRESSES ARE CALCULATED AND PRINTED
C
      CALL CAUCHY
C
  800 IF (IPRI.NE.0) RETURN
      IF (INDNL.LE.2 .OR. ITYP2D.LT.2) GO TO 801
      XBAR=THIC*DEXP(STRAIN(4))
C
  801 CALL MAXMIN (STRESS,SX,SY,SM)
      IF (IPS.LT.0) GO TO 850
C
C     STRESS PRINTOUT ONLY
C
      IF (IPT.GT.1) GO TO 820
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
  820 WRITE (6,2100) IPT,STATE(IPELD),STRESS(4),(STRESS(J),J=1,3),
     1               SX,SY,SM
      IF (INDNL.EQ.3 .AND. ITYP2D.GE.2) GO TO 830
      WRITE (6,2200) FT,YIELDD,EPSTRD
C
      RETURN
C
  830 WRITE (6,2300) FT,YIELDD,EPSTRD,XBAR
C
      RETURN
C
C     STRESS AND STRAIN PRINTOUT
C
  850 IF (IPT.GT.1) GO TO 870
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
  870 WRITE (6,2100) IPT,STATE(IPELD),STRESS(4),(STRESS(J),J=1,3),
     1               SX,SY,SM
C
      IF (INDNL.EQ.3) GO TO 880
C
      WRITE (6,2400) STRAIN(4),(STRAIN(J),J=1,3)
      WRITE (6,2500) EPSP(4),(EPSP(J),J=1,3)
      IF (INDNL.EQ.3 .AND. ITYP2D.GE.2) GO TO 880
      WRITE (6,2200) FT,YIELDD,EPSTRD
C
      RETURN
C
  880 CONTINUE
      IF (ITYP2D.LT.2) WRITE (6,2200) FT,YIELDD,EPSTRD
      IF (ITYP2D.GE.2) WRITE (6,2300) FT,YIELDD,EPSTRD,XBAR
C
      RETURN
C
 2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,13X,
     1        2HYY,13X,2HZZ,13X,2HYZ,9X,10HMAX STRESS,5X,10HMIN STRESS,
     2        3X,5HANGLE,/,1X,7HNUM/IPT,3X,5HSTATE,4X,10HCOMPONENTS)
 2005 FORMAT (/,1X,I3)
 2100 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,6(E14.6,1X),F6.2)
 2200 FORMAT (20X,19HEFFECTIVE STRESS = ,E14.6,
     1        1X,15HYIELD STRESS = ,E14.6,
     2        1X,29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/)
 2300 FORMAT (20X,19HEFFECTIVE STRESS = ,E14.6,
     1        1X,15HYIELD STRESS = ,E14.6,
     2        1X,29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/,
     3        20X,12HTHICKNESS = ,E14.6,/)
 2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,4(E14.6,1X))
 2500 FORMAT (25X,7HPLASTIC,3X,4(E14.6,1X))
 2600 FORMAT (20X,22HPRINCIPAL STRETCHES = ,3(E14.6,2X))
 2700 FORMAT (20X,39HDIRECTION COSINES OF MAXIMUM STRETCH = ,
     1        3(E14.6,2X))
C
      END
