C *CDC* *DECK CMOD3D
C *UNI* )FOR,IS  N.CMOD3D, R.CMOD3D
      SUBROUTINE CMOD3D (NEL,EKK,RKLD,RKUN,GLD,SP33,SIG,EPS,EVMAX,
     1                  EVGRAV,PGRAV,DCA,CRKSTR,STRESS,STRAIN,C,IPT,
     2                   NODS,TEMPV1,TEMPV2,XYZ,NOD9,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 .      DCA       ORIENTATION 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
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 /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
     1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /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),SIG(6),EPS(6),DCA(4),
     1          CRKSTR(3),STRESS(6),STRAIN(6),C(6,6),RLMN(3,3),NODS(1),
     2          TEMPV1(1),TEMPV2(1),XYZ(1),NOD9(1),WA(1),DUMWA(22),
     3          SP33(1)
      EQUIVALENCE (SIGP(1),P1), (SIGP(2),P2), (SIGP(3),P3)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ),(NPAR(17),NCON)
     1           ,(NPAR(15),MODEL),(NPAR(19),ITHERM),(NPAR(3),INDNL)
C
      IF (IUPDT .EQ. 0) GO TO 3
      DO 1 I=1,22
    1 DUMWA(I)=WA(I)
C
    3 IF (MODEL.EQ.4) FALSTR = PGRAV
      NPT=NINT*NINT*NINTZ
      IPOINT=6
      MOD45=1
      NUMCRK=0
      ANGPRI=100.
      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(3))/3.
      T11=SIG(1) - TMM
      T22=SIG(2) - TMM
      T33=SIG(3) - TMM
      T12=SIG(4)
      T13=SIG(5)
      T23=SIG(6)
C
      EVV=-(EPS(1)+EPS(2)+EPS(3))
      EMM=-EVV/3.
      E11=EPS(1) - EMM
      E22=EPS(2) - EMM
      E33=EPS(3) - EMM
      E12=EPS(4)
      E13=EPS(5)
      E23=EPS(6)
C
      SBAR=((SIG(1)-SIG(2))**2+(SIG(2)-SIG(3))**2+(SIG(3)-SIG(1))**2)/6.
      SBAR=SBAR + SIG(4)**2 + SIG(5)**2 + SIG(6)**2
      IF (MODEL.EQ.5) EVV=DSQRT(SBAR) + 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
      IF (MODEL.EQ.4) EVTOT=EVMAX + EVGRAV
      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
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. (DCA(4).GT.10. .OR. PGRAV.EQ.100.))
     1 CALL PRNCP3 (SIG,EPS,RLMN,RKLD,RKUN,GLD,SP33,TEP,PGRAV,MODEL,1)
      IF (DCA(4).LE.1. .AND. PGRAV.NE.100.)
     1 CALL CRAK3D (SIG,EPS,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     2              RLMN,TEP,NUMCRK,MODEL,1)
C
C     ROTATE INCREMENTAL STRAINS TO PREVIOUS TIME PRINCIPAL/CRACK PLANES
C
      IF (IKAS.GT.0 .AND. (DCA(4).GT.10. .OR. PGRAV.EQ.100.))
     1 CALL PRNCP3 (SIG,STRAIN,RLMN,RKLD,RKUN,GLD,SP33,EP,PGRAV,MODEL,2)
      IF (DCA(4).LE.1. .AND. PGRAV.NE.100.)
     1 CALL CRAK3D (SIG,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     2              RLMN,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
      NUMSIG=1
      IF (PGRAV.EQ.100.) NUMSIG=3
      DO 6 I=NUMSIG,3
      YP(I)=E
      IF (SIGP(I).GE.0.001*SIGCP) GO TO 6
C
      YP(I)=0.
      DO 4 L=1,NUMINT
      E1=XG(L,NUMINT)
      DE=TEP(I) + (1 + E1)*(EP(I) - TEP(I))/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(3)
      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
      E13=E
      DENM=DABS(P1) + DABS(P3)
      IF (DENM.NE.0.) E13=(DABS(P1)*YP(1) + DABS(P3)*YP(3))/DENM
      E23=E
      DENM=DABS(P2) + DABS(P3)
      IF (DENM.NE.0.) E23=(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,2000) 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 (DCA(4).GT.10.) GO TO 50
      CALL CRAK3D (SIG,EPS,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     1              RLMN,TEP,NUMCRK,MODEL,1)
      CALL CRAK3D (SIG,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     1              RLMN,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 (DCA(4).GT.10. .AND. MOD45.EQ.1) GO TO 50
C
   47 CALL DCRAK3 (C,SIG,RLMN,MODEL,NUMCRK,1,1)
C
      DO 57 I=1,3
      K=I + 3
      SIGP(K)=SIGP(K) + C(K,K)*(EP(K) - TEP(K))
      DO 57 J=1,3
   57 SIGP(I)=SIGP(I) + C(I,J)*(EP(J) - TEP(J))
C
      IF (MODEL.EQ.4) GO TO 58
      TEP(1)=EP(1)
      TEP(2)=EP(2)
      TEP(3)=EP(3)
   58 IF (DCA(4).LE.1.0)
     1  CALL CRAK3D (STRESS,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
     1              RLMN,EP,NUMCRK,MODEL,3)
C
      CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
C
      IF (DCA(4).GT.10.) GO TO 60
      EVI=-(STRAIN(1) + STRAIN(2) + STRAIN(3))
      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(3))
      EPSMM=-EVI/3.
      EPS11=STRAIN(1)-EPSMM
      EPS22=STRAIN(2)-EPSMM
      EPS33=STRAIN(3)-EPSMM
      EPS12=STRAIN(4)
      EPS13=STRAIN(5)
      EPS23=STRAIN(6)
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
      S13=   G*(EPS13-E13)+T13
      S23=   G*(EPS23-E23)+T23
C
      STRESS(1)=S11+PEE
      STRESS(2)=S22+PEE
      STRESS(3)=S33+PEE
      STRESS(4)=S12
      STRESS(5)=S13
      STRESS(6)=S23
C
C
C        5. DETERMINE WHETHER CURRENT STRESSES HAVE CAUSED CRACKING
C           OR CRUSHING TO OCCUR
C
C
   60 CALL PRNCP3 (STRESS,STRAIN,RLMN,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(3)=EP(3)
      IF (PGRAV.NE.100.) GO TO 59
      NUMCRK=4
      CALL DCRAK3 (C,STRESS,RLMN,MODEL,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
      IF (MODEL.GT.4) GO TO 150
      PTOT=-PGRAV + P1
      IF (PTOT.LE.0.0) GO TO 65
      NUMCRK=1
      IF (P2.GT.PGRAV) NUMCRK=2
      IF (P3.GT.PGRAV) NUMCRK=3
      DCA(1)=RLMN(1,1)
      DCA(2)=RLMN(2,1)
      DCA(3)=RLMN(1,2)
      DCA(4)=RLMN(2,2)
      IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
      IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
      CRKSTR(1)=EP(1)
      CRKSTR(2)=EP(2)
      CRKSTR(3)=EP(3)
      CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
      ILFSET=1
C
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,2015)
      WRITE(6,2035) NEL
   66 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 67
C
      IF (DCA(4).LE.1.0) GO TO 165
      IF (MODEL.GT.4) GO TO 150
      PTOT=-PGRAV + P1
      IF (PTOT.GT.0.0) ANGPRI=RLMN(2,2)
      IF (ANGPRI.LE.1.0) NUMCRK=1
      IF (P2.GT.PGRAV) NUMCRK=2
      IF (P3.GT.PGRAV) NUMCRK=3
      GO TO 160
C
C     CHECK FOR CRACKING OR CRUSHING OF CONCRETE FOR THE FIRST TIME
C
  150 IF (P1.LT.0.) GO TO 155
      IF (P1.GT.FALSTR) NUMCRK=1
      IF (P2.GT.FALSTR) NUMCRK=2
      IF (P3.GT.FALSTR) NUMCRK=3
  155 IF (P3.LE.SIGCP) NUMCRK=4
      IF (NUMCRK.GT.0) ANGPRI=RLMN(2,2)
      IF (NUMCRK.EQ.4) FALSTR=SIGCP
C
      IF (KPRI.EQ.0) GO TO 160
      IF (NUMCRK.EQ.0) GO TO 70
      DCA(1)=RLMN(1,1)
      DCA(2)=RLMN(2,1)
      DCA(3)=RLMN(1,2)
      DCA(4)=RLMN(2,2)
      IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
      IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
      CRKSTR(1)=EP(1)
      CRKSTR(2)=EP(2)
      CRKSTR(3)=EP(3)
C
      IF (NUMCRK.NE.4) GO TO 159
      PGRAV=100.
      CRKSTR(1)=SIGCP
      CRKSTR(2)=EPSCP
C
  159 CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
      ILFSET=1
C
      GO TO 70
C
  160 IF (ANGPRI.GT.10.) GO TO 67
      CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
C
  165 NF=NUMCRK + 1
      IF (INDNL .EQ. 2) CALL CAUCH3
      IF (IPRI.NE.0) GO TO 70
      GO TO (61,62,63,64,68), NF
   61 WRITE(6,2040) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
      GO TO 70
   62 WRITE(6,2041) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
      GO TO 70
   63 WRITE(6,2042) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
      GO TO 70
   64 WRITE(6,2043) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
      GO TO 70
   68 WRITE (6,2044) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
      GO TO 70
   67 IF (INDNL .EQ. 2) CALL CAUCH3
      IF (IPRI.NE.0) GO TO 70
      WRITE (6,2045) IPT,(STRESS(I),I=1,6),P1,P2,P3,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)
      SIG(5)=STRESS(5)
      SIG(6)=STRESS(6)
C
      EPS(1)=STRAIN(1)
      EPS(2)=STRAIN(2)
      EPS(3)=STRAIN(3)
      EPS(4)=STRAIN(4)
      EPS(5)=STRAIN(5)
      EPS(6)=STRAIN(6)
      IF (KPRI .EQ. 0) RETURN
      IF (ICOUNT.EQ.3) RETURN
C
      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(3))**2+(SIG(2)-SIG(3))**2)/6.
      SBAR=SBAR + SIG(4)**2 + SIG(5)**2 + SIG(6)**2
      EVI=DSQRT(SBAR) + ALFA*(SIG(1) + SIG(2) + SIG(3))
      IF (IKAS.EQ.1 .AND. ILFSET.EQ.1) EVMAX=EVI
C
   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 130
   95 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 101
      IF (DCA(4) .LE. 1.0) GO TO 130
C
C     ISOTROPIC STRESS-STRAIN LAW
C
  101 DUM=0.6666667 * G
      A1=RK + 2.*DUM
      B1=RK - DUM
C
      DO 110 I=1,6
      DO 110 J=1,6
  110 C(I,J)=0.0
C
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=B1
      C(2,1)=B1
      C(2,2)=A1
      C(2,3)=B1
      C(3,1)=B1
      C(3,2)=B1
      C(3,3)=A1
      DO 120 I=4,6
  120 C(I,I)=G
C
      GO TO 200
C
C     CRACKED / ORTHOTROPIC STRESS-STRAIN LAW
C
  130 CALL DCRAK3 (C,SIG,RLMN,MODEL,NUMCRK,2,1)
C
  200 IF (ITHERM.GT.0) CALL THERM3 (NODS,NOD9,XYZ,EKK,TEMPV2,EPS,TMPOLD)
      IF (MODEL.EQ.5) EVGRAV=TMPOLD
C
      IF (IUPDT .EQ. 0) RETURN
      DO 210 I=1,22
  210 WA(I)=DUMWA(I)
      RETURN
C
C
 2000 FORMAT(///36H ***ERROR  CURRENT VOLUMETRIC STRAIN,E14.6,2X,
     1       13HFOR ELEMENT (,I2,1H)/11X,21HEXCEEDS TABLE MAXIMUM,
     2       E14.6//8H ***STOP)
 2015 FORMAT (/10H ELMT  INT,101X,7H(PGRAV),/10H  NO   PT ,
     1        2X,7HSIGMAXX,4X,7HSIGMAYY,4X,7HSIGMAZZ,4X,7HSIGMAXY,4X,
     2        7HSIGMAXZ,4X,7HSIGMAYZ,3X,8HSIGMA P1,3X,8HSIGMA P2,3X,
     3        8HSIGMA P3,4X,7HFAILSTR /)
 2035 FORMAT (I4)
 2040 FORMAT (I9,1X,10E11.3,8H  CLOSED  )
 2041 FORMAT (I9,1X,10E11.3,8H 1 CRACK  )
 2042 FORMAT (I9,1X,10E11.3,8H 2CRACKS  )
 2043 FORMAT (I9,1X,10E11.3,8H 3CRACKS  )
 2044 FORMAT (I9,1X,10E11.3,8H CRUSHED  )
 2045 FORMAT (I9,1X,10E11.3,8H NOCRACK  )
C
      END
C *CDC* *DECK PRNCP3
C *UNI* )FOR,IS N.PRNCP3, R.PRNCP3
      SUBROUTINE PRNCP3 (STR,EPS,RLMN,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 /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGMA(6),TEP(6),EP(6),YP(3),
     1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION STR(6),EPS(1),RLMN(3,3),SP1(1),SP31(1),SP32(1),SP33(1),
     1          EPSL(1),T(6,6),S(3,3),IPRM(3),IPERM(3),ICOL(3)
      EQUIVALENCE (SIGMA(1),P1),(SIGMA(2),P2),(SIGMA(3),P3)
      DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
C
C     FIND THE STRESS INVARIANTS - 1. MEAN STRESS
C
      IF (KKK.GT.1) GO TO 95
      STRAV=(STR(1) + STR(2) + STR(3))/3.
C
      S(1,1)=STR(1) - STRAV
      S(2,2)=STR(2) - STRAV
      S(3,3)=STR(3) - STRAV
      S(1,2)=STR(4)
      S(1,3)=STR(5)
      S(2,3)=STR(6)
      S(2,1)=S(1,2)
      S(3,1)=S(1,3)
      S(3,2)=S(2,3)
C
C     2. 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     3. 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 - SIN(3*PHI)=-(3*3**.5/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.D0) GO TO 32
      IF (DABS(TEMP) .LE. 1.0001) GO TO 34
      WRITE (6,2000)
      STOP
   34 IF (TEMP .LT. (-1.D0)) TEMP=-1.D0
      IF (TEMP .GT. 1.D0) TEMP=1.D0
   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     FIND PRINCIPAL STRESSES
C
      A1=2.*SBAR/DSQRT(3.0D0)
      SIGMA(1)=A1*DSIN(PHI + 2.*PI/3.) + STRAV
      SIGMA(2)=A1*DSIN(PHI) + STRAV
      SIGMA(3)=A1*DSIN(PHI + 4.*PI/3.) + STRAV
      SIGMA(4)=0.
      SIGMA(5)=0.
      SIGMA(6)=0.
C
C     FIND THE DIRECTION COSINES OF THE PRINCIPAL STRESSES
C
      TOL=0.01
      IND=0
      SPREAD=SIGMA(1) - SIGMA(3)
      ROERR=DABS(SIGMA(1))*0.000001
      IF (SIGMA(1).EQ.0.) ROERR=DABS(SIGMA(3))*0.000001
      IF (SPREAD.LE.ROERR) GO TO 82
      DIF1=SIGMA(1) - SIGMA(2)
      DIF2=SIGMA(2) - SIGMA(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)=STR(J1) - SIGMA(I1)
   35 RLMN(J1,I1)=0.
      S(1,2)=STR(4)
      S(1,3)=STR(5)
      S(2,3)=STR(6)
      S(2,1)=S(1,2)
      S(3,1)=S(1,3)
      S(3,2)=S(2,3)
C
C     GAUSS ELIMINATION WITH SEARCH FOR LARGEST PIVOT
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
      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
      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
      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
      I1=3
      IF (IND.EQ.3) I1=1
   78 CONTINUE
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     STRAIN TRANSFORMATION MATRIX
C
      DO 90 I1=1,3
      I2=IPRM(I1)
      I3=IPERM(I1)
      DO 86 J1=1,3
      J2=IPRM(J1)
      J3=IPERM(J1)
      T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
      T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
      T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
      T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
   86 CONTINUE
   90 CONTINUE
C
C     FIND STRAINS IN THE PRINCIPAL STRESS COORDINATE SYSTEM
C
   95 DO 110 I=1,6
      EPSL(I)=0.
      DO 110 J=1,6
  110 EPSL(I)=EPSL(I) + T(I,J)*EPS(J)
      IF (KKK.EQ.2) RETURN
      IF (MODEL.EQ.4) RETURN
      IF (PGRAV.EQ.100.) RETURN
C
C     FIND FAILURE STRESSES FROM THE FAILURE ENVELOPE
C
      SIGCP=SIGMAC
      EPSCP=EPSC
      FALSTR=SIGMAT
      IF (P1.LT.0. .AND. P2.LT.0. .AND. P3.LT.0.) GO TO 135
      IF (P2.LT.0. .AND. P3.LT.0.) GO TO 130
      IF (P3.LT.0.) GO TO 120
      FALSTR=SIGMAT
      GO TO 200
  120 FALSTR=SIGMAT*(1. - P3/SIGMAC)
      GO TO 200
  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
  200 RETURN
C
 2000 FORMAT (//46H STOP, ERROR IN PRINCIPAL STRESS CALCULATIONS  /)
 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 PRNCP3.
     1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
     2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
C
      END
C *CDC* *DECK THERM3
C *UNI* )FOR,IS N.THERM3, R.THERM3
      SUBROUTINE THERM3 (NODS,NOD9,XYZ,PROP,TEMPV2,EPS,TMPOLD)
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 /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION NODS(1),NOD9(1),XYZ(1),PROP(1),TEMPV2(1),H(21),P(3,21),
     1          XJ(3,3),EPS(1)
C
C     CALCULATE INITIAL STRAIN DUE TO TEMPERATURE
C
      IINTP=1
      CALL FUNCT (R,S,T,H,P,NOD9,XJ,DET,XYZ,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=3
      DO 50 I=1,IST
      EPS(I)=EPS(I) + DEPST
      DO 50 J=1,IST
   50 STRESS(I)=STRESS(I) - C(I,J)*DEPST
C
C     UPDATE OLD TEMPERATURE TO CURRENT TEMPERATURE
C
      TMPOLD=CTEMP
C
      RETURN
C
      END
C *CDC* *DECK CRAK3D
C *UNI* )FOR,IS N.CRAK3D, R.CRAK3D
      SUBROUTINE CRAK3D (STR,EPS,DCA,PGRAV,CRKSTR,SP1,SP31,SP32,SP33,
     1                   RLMN,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 /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
     1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION STR(1),EPS(1),DCA(4),CRKSTR(3),SP1(1),SP31(1),SP32(1),
     1          SP33(1),RLMN(3,3),EPSL(6),T(6,6),IPRM(3),IPERM(3),SIG(3)
      DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
C
      IF (KKK.EQ.2) GO TO 95
      RLMN(1,1) = DCA(1)
      NUMCRK=1
      IF (DCA(1) .LE. -50.) NUMCRK=2
      IF (DCA(1) .GE. 49.) NUMCRK=3
      IF (DCA(1) .GE. 99.) NUMCRK=0
      IF (NUMCRK.EQ.2) RLMN(1,1) = DCA(1) + 51.
      IF (NUMCRK.EQ.3) RLMN(1,1) = DCA(1) - 50.
      IF (NUMCRK.EQ.0) RLMN(1,1) = DCA(1) - 100.
      NCROLD=NUMCRK
      IF (KKK.EQ.3) GO TO 107
C
C     GENERATE DIRECTION COSINES ARRAY RLMN FROM DCA
C
      RLMN(2,1) = DCA(2)
      RLMN(1,2) = DCA(3)
      RLMN(2,2) = DCA(4)
      TEMP1=RLMN(1,1)*RLMN(1,1) + RLMN(2,1)*RLMN(2,1)
      TEMP2=RLMN(1,2)*RLMN(1,2) + RLMN(2,2)*RLMN(2,2)
      IF (TEMP1.LE.1.00001 .AND. TEMP2.LE.1.00001) GO TO 20
      WRITE (6,3200) (DCA(I),I=1,4)
      STOP
C
   20 IF (TEMP1.GT.1.) TEMP1=1.
      IF (TEMP2.GT.1.) TEMP2=1.
      RLMN(3,1)=DSQRT(1. - TEMP1)
      RLMN(3,2)=DSQRT(1. - TEMP2)
C
      X=RLMN(2,1)*RLMN(3,2) - RLMN(3,1)*RLMN(2,2)
      Y=RLMN(3,1)*RLMN(1,2) - RLMN(1,1)*RLMN(3,2)
      Z=RLMN(1,1)*RLMN(2,2) - RLMN(2,1)*RLMN(1,2)
      XLN=DSQRT(X*X + Y*Y + Z*Z)
      XLN=1.0/XLN
      RLMN(1,3)=X*XLN
      RLMN(2,3)=Y*XLN
      RLMN(3,3)=Z*XLN
C
C     OBTAIN CRACK PLANE STRESSES AND STRAINS
C
C     STRAIN TRANSFORMATION
C
      DO 90 I1=1,3
      I2=IPRM(I1)
      I3=IPERM(I1)
      DO 80 J1=1,3
      J2=IPRM(J1)
      J3=IPERM(J1)
      T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
      T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
      T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
      T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
   80 CONTINUE
   90 CONTINUE
C
   95 DO 100 I=1,6
      EPSL(I)=0.
      DO 100 J=1,6
  100 EPSL(I)=EPSL(I) + T(I,J)*EPS(J)
      IF (KKK.EQ.2) RETURN
C
C     STRESS TRANSFORMATION
C
      DO 105 I=1,3
      DO 105 J=4,6
      T(J,I)=T(J,I)*0.5
  105 T(I,J)=2.*T(I,J)
C
      DO 108 I=1,6
      SIGP(I)=0.
      DO 108 J=1,6
  108 SIGP(I)=SIGP(I) + T(I,J)*STR(J)
C
C     TEST TO SEE WHICH DIRECTIONS HAVE OPEN CRACKS AT CURRENT STRESSES
C
  107 IF (MODEL.EQ.4) 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(3)
C
  109 NF=NUMCRK + 1
      GO TO (110,111,180,190), NF
C
  110 IF (SIGP(1).LT.FALSTR .AND. SIGP(2).LT.FALSTR .AND.
     1    SIGP(3).LT.FALSTR) GO TO 112
      NUMCRK=1
      DCA(1)=DCA(1) - 100.
      CRKSTR(1)=EPSL(1)
      CRKSTR(2)=EPSL(2)
      CRKSTR(3)=EPSL(3)
      GO TO 112
C
  111 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=0
      R11=(SIGP(2) + SIGP(3))*0.5
      R12=(SIGP(2) - SIGP(3))*0.5
      RAD=DSQRT(R12*R12 + SIGP(6)*SIGP(6))
      SIG(2)=R11 + RAD
      SIG(3)=R11 - RAD
      IF (MODEL.EQ.5 .AND. SIG(3).LT.0.) FALSTR=SIGMAT*(1. - SIG(3)/
     1                                                          SIGMAC)
      IF (SIG(2).GT.FALSTR) NUMCRK=2
      IF (SIG(3).GT.FALSTR) NUMCRK=3
      IF (NUMCRK.EQ.0) DCA(1)=DCA(1) + 100.
      IF (NUMCRK.LE.1) GO TO 112
C
      S11=(EPSL(2) + EPSL(3))*0.5
      S12=(EPSL(2) - EPSL(3))*0.5
      RAD=DSQRT(S12*S12 + EPSL(6)*EPSL(6)/4.)
      EPS2=S11 + RAD
      EPS3=S11 - RAD
      IF (NUMCRK.EQ.2) CRKSTR(2)=EPS2
      IF (NUMCRK.EQ.3) CRKSTR(3)=EPS3
      IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
      IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
      IF (SIGP(6).EQ.0.) GO TO 112
      SIGP(2)=SIG(2)
      SIGP(3)=SIG(3)
      EPSL(2)=EPS2
      EPSL(3)=EPS3
      EPSL(6)=0.
      ANG=DATAN(1.0D0)
      IF (DABS(R12).GT.0.000001) ANG=DATAN2(SIGP(6),R12)*0.5
      SIGP(6)=0.
      SG=DSIN(ANG)
      CG=DCOS(ANG)
      DCA(3)=RLMN(1,2)*CG + RLMN(1,3)*SG
      DO 113 J=1,3
      DUMY= RLMN(J,2)*CG + RLMN(J,3)*SG
      RLMN(J,3)=-RLMN(J,2)*SG + RLMN(J,3)*CG
  113 RLMN(J,2)=DUMY
      DCA(3)=RLMN(1,2)
      DCA(4)=RLMN(2,2)
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
  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=1
      IF (NUMCRK.EQ.1) DCA(1) = DCA(1) + 51.
      IF (NUMCRK.NE.1 .AND. SIGP(3).GE.FALSTR) NUMCRK=3
      IF (NUMCRK.EQ.3) DCA(1) = DCA(1) + 101.
      IF (MODEL.NE.5 .OR. SIGP(3).GT.SIGMAC) GO TO 200
C
  185 NUMCRK=4
      CRKSTR(1)=SIGCP
      CRKSTR(2)=EPSCP
      FALSTR=SIGCP
      PGRAV=100.
      GO TO 200
C
  190 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=2
      IF (EPSL(2).LT.0. .AND. EPSL(2).LT.CRKSTR(2)) NUMCRK=2
      IF (EPSL(3).LT.0. .AND. EPSL(3).LT.CRKSTR(3)) NUMCRK=2
      IF (NUMCRK.EQ.2) DCA(1) = DCA(1) - 101.
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 CRAK3D.
     1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
     2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
 3200 FORMAT (1H1///46H STOP, ERROR IN DIRECTION COSINES CALCULATIONS,
     1             /35H ERROR OCCURED IN SUBROUTINE CRAK3D,
     2             /28H CUURENT VALUES OF DCA ARE =,/4E30.20)
C
      END
C *CDC* *DECK DCRAK3
C *UNI* )FOR,IS  N.DCRAK3, R.DCRAK3
      SUBROUTINE DCRAK3 (C,SIG,RLMN,MODEL,IK,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 /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
     1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
      DIMENSION C(6,1),SIG(1),RLMN(3,3),D(6,6),T(6,6),DSIG(6)
     1          ,IPRM(3),IPERM(3)
      DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
C
C     COMPUTE ISOTROPIC STRESS-STRAIN LAW
C
      IF (KKK.EQ.2) GO TO 42
C
      DO 5 I=1,6
      DO 5 J=I,6
    5 C(I,J)=0.0
C
      IF (MOD45.EQ.2) GO TO 8
      DUM=2.*G/3.
      A1=RK + 2.*DUM
      B1=RK - DUM
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=B1
      C(2,2)=A1
      C(2,3)=B1
      C(3,3)=A1
      C(4,4)=G
      C(5,5)=G
      C(6,6)=G
      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(2,2)=B1*YP(2)
      C(3,3)=B1*YP(3)
      C(1,2)=E12*D1
      C(1,3)=E13*D1
      C(2,3)=E23*D1
      C(4,4)=C1*E12
      C(5,5)=C1*E13
      C(6,6)=C1*E23
C
   10 IF (IK.EQ.0 .OR. IK.EQ.4) GO TO 30
C
C     MODIFY STRESS-STRAIN LAW TO ACCOUNT FOR CRACKING
C
      DO 12 I=4,6
   12 C(I,I)=C(I,I)*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)
      GO TO 14
C
   13 A1=1./(1. - VNU*VNU)
      B1=VNU*A1
      A2=A1*YP(2)
      C2=A1*YP(3)
      B2=B1*E23
      G=C1*E23
      D2=YP(3)
C
   14 IF (IK - 2) 15,20,25
C
   15 DO 16 I=1,3
   16 C(1,I)=C(1,I)*STIFAC
      C(2,2)=A2
      C(2,3)=B2
      C(3,3)=C2
      C(6,6)=G
      GO TO 30
C
   20 DO 21 I=1,2
      DO 21 J=I,3
   21 C(I,J)=C(I,J)*STIFAC
      C(3,3)=D2
      GO TO 30
C
   25 DO 26 I=1,3
      DO 26 J=I,3
   26 C(I,J)=C(I,J)*STIFAC
C
   30 DO 40 I=1,5
      DO 40 J=I,6
   40 C(J,I)=C(I,J)
      IF (ILOCAL.EQ.1) RETURN
C
   42 IF (IK.NE.4) GO TO 43
      IF (KKK.EQ.1) GO TO 90
      IF (ILOCAL.EQ.2) GO TO 90
C
C     SET UP COORDINATE TRANSFORMATION FROM CRACKED ORIENTATION
C
   43 DO 48 I1=1,3
      I2=IPRM(I1)
      I3=IPERM(I1)
      DO 47 J1=1,3
      J2=IPRM(J1)
      J3=IPERM(J1)
      T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
      T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
      T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
      T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
   47 CONTINUE
   48 CONTINUE
      IF (KKK.EQ.2) GO TO 90
C
C     ROTATE THE STRESS-STRAIN MATRIX TO GLOBAL COORDINATES
C
C     T(TRANSPOSE) * C(MATERIAL)
C
      DO 60 IR=1,6
      DO 60 IC=1,6
      D(IR,IC) = 0.0
      DO 50 IN=1,6
   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,6
      DO 80 IC=IR,6
      C(IR,IC) = 0.0
      DO 70 IN=1,6
   70 C(IR,IC) = C(IR,IC) + D(IR,IN)* T(IN,IC)
   80 C(IC,IR)=C(IR,IC)
C
   90 IF (KKK.LT.2) RETURN
      IF (MODEL.EQ.4 .AND. ICRACK.LT.2) GO TO 140
C
C     REDUCE CRACKED NORMAL ( + SHEAR)STRESSES OF PREVIOUS STEP TO ZERO
C
      DO 91 I=1,6
   91 DSIG(I)=0.
      IF (IK.LT.4) GO TO 95
      EPSUP=EPSU*EPSCP/EPSC
      IF (TEP(1).GT.EPSUP .AND. TEP(2).GT.EPSUP .AND. TEP(3).GT.EPSUP)
     1    GO TO 93
      DO 92 I=1,6
   92 SIGP(I)=0.
      GO TO 95
C
   93 IF (ILOCAL.EQ.1) GO TO 140
      RETURN
C
   95 ETATAU=0.
      IF (SHEFAC .GT. 0.001) ETATAU=1.
C
C     RELEASE APPROPRIATE STRESSES
C
      NF=IK + 1
      GO TO (140,120,110,100,155), NF
  100 SIGP(3)=0.
  110 SIGP(6)=SIGP(6)*ETATAU
      SIGP(2)=0.
  120 SIGP(5)=SIGP(5)*ETATAU
      SIGP(4)=SIGP(4)*ETATAU
      SIGP(1)=0.
C
C     ROTATE STRESSES TO GLOBAL AXES
C
  140 DO 150 IR=1,6
      DO 150 IC=1,6
  150 DSIG(IR)=DSIG(IR) + T(IC,IR)*SIGP(IC)
C
  155 DO 160 I=1,6
  160 SIG(I)=DSIG(I)
      RETURN
C
      END
C *CDC* *DECK OVL41
C *CDC*       OVERLAY (ADINA,4,1)
C *CDC* *DECK ELT3D3
C *UNI* )FOR IS  N.ELT3D3, R.ELT3D3
C *CDC*       PROGRAM ELT3D3
C
      SUBROUTINE ELT3D3
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            ,NDOFDM,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 /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON A(1)
C
      REAL A
C
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(7),MXNODS),(A(1),IA(1))
      EQUIVALENCE (NPAR(17),NCON)
C
C
C
C
C     FOR ADDRESSES N101,N102,.............SEE SUBROUTINE THREDM
C
C     QUANTITIES STORED FOR EACH ELEMENT
C
C        GLOBAL NODAL POINT NUMBERS
C
C
C
C
      NPT=NINT*NINT
      NN=N112+(NEL-1)*MXNODS
      IF(IND.NE.0) GO TO 100
C
C        1. INITIALIZE WORKING ARRAY
C
      CALL ITHEL3(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=N111+(MATP-1)*NCON*ITWO
C
C        4. DETERMINE MIDSIDE NODE ARRAY LOCATION
C
      ND9DIM=MXNODS-8
      LL=N108+(NEL-1)*ND9DIM
C
C        5. CALCULATE STRESSES AND CONSTITUTIVE LAW
C
      CALL THEL3(A(NM),A(NN),A(N6B + ITWO),A(LL))
C
  200 CONTINUE
C
      RETURN
      END
C *CDC* *DECK ITHEL3
C *UNI* )FOR,IS  N.ITHEL3, R.ITHEL3
C
      SUBROUTINE ITHEL3(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 /DPR/ ITWO
      COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
C
      DIMENSION IWA(1)
C
C
C        1. STORE GLOBAL NODAL POINT NUMBERS
C
      II=0
      DO 15 K=1,21
      IF(NODM(K).EQ.0) GO TO 15
      II=II+1
      IWA(II)=NODM(K)
   15 CONTINUE
C
      RETURN
C
      END
C *CDC* *DECK THEL3
C *UNI* )FOR,IS  N.THEL3, R.THEL3
C
      SUBROUTINE THEL3(PROP,NDS,TEMPV2,NOD9M)
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 /SOLPM3/ 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 /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
C
      DIMENSION PROP2(3),PROP(16,1),EPST(6),NDS(1),NOD9M(1),TEMPV2(1),
     1          H(21),XDM1(3,21),XDM2(3,3),XDM3(3,1)
C
      EQUIVALENCE (NPAR(3),INDNL)
C
C
C
      IF(IPT.GT.1) GO TO 5
      TOLMT=1.0D-2
      NPTS=IDINT(PROP(1,5))
      TREF=PROP(2,5)
      IINTP=1
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 FUNCT(E1,E2,E3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
      TEMP2=0.0
      DO 10 K=1,IELD
      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)
      A2=YM2/(1.+PV2)
      C2=0.5*A2
      A2=A2/(1.-2.*PV2)
      B2=A2*PV2
      A2=A2*(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)=EPST(1)
      EPST(4)=0.0
      EPST(5)=0.0
      EPST(6)=0.0
C
C        5. CALCULATE STRESSES
C
      STRESS(1)=A2*(STRAIN(1)-EPST(1))+B2*(STRAIN(2)+STRAIN(3)-
     1          EPST(2)-EPST(3))
      STRESS(2)=A2*(STRAIN(2)-EPST(2))+B2*(STRAIN(1)+STRAIN(3)
     1          -EPST(1)-EPST(3))
      STRESS(3)=A2*(STRAIN(3)-EPST(3))+B2*(STRAIN(1)+STRAIN(2)
     1          -EPST(1)-EPST(2))
      STRESS(4)=C2*STRAIN(4)
      STRESS(5)=C2*STRAIN(5)
      STRESS(6)=C2*STRAIN(6)
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,6
      DO 115 J=1,6
  115 C(I,J)=0.0
C
      C(1,1)=A2
      C(1,2)=B2
      C(1,3)=B2
      C(2,1)=B2
      C(2,2)=A2
      C(2,3)=B2
      C(3,1)=B2
      C(3,2)=B2
      C(3,3)=A2
      C(4,4)=C2
      C(5,5)=C2
      C(6,6)=C2
      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 CAUCH3
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 WRITE(6,2002)
  206 NELAST=NEL
      WRITE(6,2004) NEL
  210 WRITE(6,2005) IPT,(STRESS(J),J=1,6)
      WRITE(6,2009) TEMP2
C
 2002 FORMAT(8H ELEMENT,4X,6HOUTPUT,/,2X,6HNUMBER,2X,8HLOCATION,7X,
     1        8HSIGMA-X1,7X,8HSIGMA-X2,7X,8HSIGMA-X3,8X,7HTAU-X12,8X,
     2        7HTAU-X13,8X,7HTAU-X23,/,1X)
 2004 FORMAT(I4,/)
 2005 FORMAT(13X,I2,7X,6(E14.6,1X))
 2008 FORMAT(92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PROPER
     1TY TEMPERATURES   (SUBROUTINE THEL3))
 2009 FORMAT(14X,14HTEMPERATURE = ,E14.6,/)
C
      RETURN
C
      END
C *CDC*  *DECK OVL43
C *CDC*       OVERLAY (ADINA,4,3)
C *CDC* *DECK ELT3D6
C *UNI* )FOR,IS  N.ELT3D6, R.ELT3D6
C *CDC*       PROGRAM ELT3D6
      SUBROUTINE ELT3D6
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     M O D E L     =     6
C
      RETURN
      END
C *CDC* *DECK OVL44
C *CDC*       OVERLAY (ADINA,4,4)
C *CDC* *DECK ELT3D7
C *UNI* )FOR,IS  N.ELT3D7, R.ELT3D7
C *CDC*       PROGRAM ELT3D7
      SUBROUTINE ELT3D7
C
C     M O D E L  =  7
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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DPR/ ITWO
      COMMON A(1)
C
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (NPAR(10),NINT),(A(1),IA(1)),(NPAR(11),NINTZ)
C
C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE THREDM
C
C
      IDW=14*ITWO
      NPT=NINT*NINT*NINTZ
      MATP=IA(N107 + NEL - 1)
      NM=N111 + (MATP-1)*8*ITWO
      IF(IND.NE.0) GO TO 100
C
C     INITIALIZE WORKING ARRAY
C
      NN=N112 + (NEL-1)*NPT*IDW
C
      CALL IDRK3(A(NN),A(NN),A(NM),NPT,IDW)
C
      GO TO 500
C
C     FIND MATERIAL LAW AND STRESSES
C
  100 NS=N112 + ((NEL-1)*NPT + (IPT-1))*IDW
      NS1=NS + 6*ITWO
      NS2=NS + 12*ITWO
      NS3=NS + 13*ITWO
      CALL DRUCK3(A(NM), A(NS), A(NS1), A(NS2), A(NS3))
  500 CONTINUE
C
      RETURN
      END
C *CDC* *DECK IDRK3
C *UNI* )FOR,IS  N.IDRK3, R.IDRK3
      SUBROUTINE IDRK3(WA,IWA,PROP,NPT,IDW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DPR/ ITWO
      DIMENSION WA(14,1),IWA(IDW,1),PROP(1)
C
C
      DO 25 J=1,NPT
C
C     SET INITIAL STRESSES AND STRAINS EQUAL TO ZERO
C
      DO 15 I=1,12
      WA(I,J)=0.0
   15 CONTINUE
C
C     SET INITIAL CAP POSITION
C
      WA(13,J)=PROP(8)
C
C     SET INITIAL STRESS STATE TO ELASTIC
C
      KJ=13*ITWO + 1
      IWA(KJ,J)=1
C
   25 CONTINUE
C
      RETURN
      END
C *CDC* *DECK DRUCK3
C *UNI* )FOR,IS  N.DRUCK3, R.DRUCK3
      SUBROUTINE DRUCK3(PROP,SIG,EPS,XI1A,IPEL)
C
C
C
C
C     SIG     STRESSES AT THE END OF THE PREVIOUS UPDATE
C     EPS     STRAINS AT THE END OF THE PREVIOUS UPDATE
C     RATIO   PART OF THE 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 IS 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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
C
      DIMENSION PROP(1),SIG(1),EPS(1),SS(6),DSS(6)
      DIMENSION DELSIG(6),DELEPS(6),DEPS(6),STATE(2),SS1(6),TEPS(6)
      DIMENSION EPSP(6)
C
      EQUIVALENCE (NPAR(3),INDNL),(DELEPS(1),DEPS(1)),(SS1(1),SS(1))
      DATA STATE /2H E,2H*P/
C
      XI1AD=XI1A
      IPELD=IPEL
      IF(IPT.NE.1) GO TO 110
C
C        1. CALCULATE MATERIAL CONSTANTS
C
      YM=PROP(1)
      PV=PROP(2)
      BM=YM/(1.0 - 2.0*PV)/3.0
      G=YM/(1.0 + PV)/2.0
      A1=BM + 4.0*G/3.0
      B1=BM - 2.0*G/3.0
      B3=1.0/(3.0*BM)
      C1=G
C
      A1I=1.0/YM
      B1I=-PV/YM
      C1I=1.0/C1
C
      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,6
      TEPS(I)=EPS(I)
  120 DELEPS(I)=STRAIN(I)-EPS(I)
C
C        3. CALCULATE THE STRESS INCREMENT,
C           ASSUMING ELASTIC BEHAVIOR
C
      DELSIG(1)=A1*DELEPS(1) + B1*(DELEPS(2) + DELEPS(3))
      DELSIG(2)=A1*DELEPS(2) + B1*(DELEPS(1) + DELEPS(3))
      DELSIG(3)=A1*DELEPS(3) + B1*(DELEPS(1) + DELEPS(2))
      DELSIG(4)=C1*DELEPS(4)
      DELSIG(5)=C1*DELEPS(5)
      DELSIG(6)=C1*DELEPS(6)
C
C        4. CALCULATE TOTAL STRESSES AND INVARIANTS,
C           ASSUMING ELASTIC BEHAVIOR
C
  150 DO 160 I=1,6
  160 STRESS(I)=SIG(I) + DELSIG(I)
      CALL DEVST3(SIG,SS1,XI11,XJ21)
      CALL DEVST3(STRESS,DSS,XI12,XJ22)
      DXI1=XI12 - XI11
      DO 165 J=1,6
  165 DSS(J)=DSS(J) - SS1(J)
      SX=SS1(1)
      SY=SS1(2)
      SZ=SS1(3)
      SXZ=SS1(5)
      SXY=SS1(4)
      SYZ=SS1(6)
      DX=DSS(1)
      DY=DSS(2)
      DZ=DSS(3)
      DXY=DSS(4)
      DXZ=DSS(5)
      DYZ=DSS(6)
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     ELASTIC STRESS STATE EXCEEDS TENSION CUTOFF LIMIT
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 + DXZ*DXZ + DYZ*DYZ)
      FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
      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 + DXZ*DXZ + DYZ*DYZ)
      FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
      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.3.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 + DXZ*DXZ + DYZ*DYZ)
      FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
      FT=DSQRT(XJ21 + FT2*FT3 + FT1*FT4) + ALFA*XI1AD - XK
C
      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
C     DOES NOT EXCEED TENSION CUTOFF **
C
  200 IPELD=1
      GO TO 700
C
C        6. ELASTIC STRESS STATE LIES OUTSIDE THE YIELD SURFACE
C           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) + 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.0*A*CC))/(2.0*A)
      IF(A.GT.0.0) GO TO 300
C
      RATIO1=RATIO
      RATIO2=(-B - DSQRT(B*B - 4.0*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
      STRESS(1)=TCUT/3.0
      STRESS(2)=TCUT/3.0
      STRESS(3)=TCUT/3.0
      STRESS(4)=0.0
      STRESS(5)=0.0
      STRESS(6)=0.0
      GO TO 700
C
C        7. UPDATE STRESS(I) AND TEPS(I) TO
C           THE START OF YIELDING
C
  300 DO 310 J=1,6
  310 STRESS(J)=SIG(J) + RATIO*DELSIG(J)
C
      DO 315 J=1,6
  315 TEPS(J)=EPS(J) + RATIO*DELEPS(J)
C
C        8. DETERMINE TYPE OF VERTEX YIELDING,
C           IF NECESSARY
C
      IF(ICHK.NE.3) GO TO 350
      DVSTR=DELEPS(1) + DELEPS(2) + DELEPS(3)
      CALL DEVST3(STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
C
      XLMDP=ALFA*3.0*BM*DVSTR + (G/XJ2)*(SX*DELEPS(1) + SY*DELEPS(2)
     1      + SZ*DELEPS(3) + SXY*DELEPS(4) + SXZ*DELEPS(5) +
     2      SYZ*DELEPS(6))
      XLMC=-3.0*BM*DVSTR
      XDUM=3.0*ALFA*XLMDP
      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
C     DETERMINE SUBDIVISION FOR NUMERICAL INTEGRATION OF
C     THE STRESS-STRAIN LAW **
C
  350 M=25
      XM=(1.0 - RATIO)/DBLE(FLOAT(M))
C
C     SUBDIVIDE STRAIN INCREMENT **
C
      DO 355 I=1,6
  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 PRAG3(DEPS,IPELD)
C
  422 DO 425 I=1,6
      DO 425 J=1,6
  425 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
C
C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
C
      CALL DEVST3(STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
      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*SZ + XI1/3.0
      STRESS(4)=GAMMA*SXY
      STRESS(5)=GAMMA*SXZ
      STRESS(6)=GAMMA*SYZ
C
      XI1=STRESS(1) + STRESS(2) + STRESS(3)
C
C     UPDATE TEPS(I) *
C
  430 DO 432 I=1,6
  432 TEPS(I)=TEPS(I) + DEPS(I)
C
C     CHECK FOR TENSION CUTOFF *
C
      IF(XI1.LT.TCUT) GO TO 435
      IPELD=6
      STRESS(1)=TCUT/3.0
      STRESS(2)=TCUT/3.0
      STRESS(3)=TCUT/3.0
      STRESS(4)=0.0
      STRESS(5)=0.0
      STRESS(6)=0.0
      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 DEVST3(STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
      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(3)) + BB*(SX*DEPS(1) +
     1       SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5)
     2       + SYZ*DEPS(6))
      VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
     1      + STRESS(3))
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(3)) - B3*(STRESS(1) + STRESS(2)
     1      + STRESS(3))
C
      IF(IPELD.EQ.4) CALL VERT3(DEPS,VPSTR)
      IF(IPELD.EQ.5) CALL CAP3(DEPS,VPSTR)
C
      DO 455 I=1,6
      DO 455 J=1,6
  455 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
C
C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
C
      CALL DEVST3(STRESS,SS,XI1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
      FT=ALFA*XI1 + DSQRT(XJ2) - XK
      IF(IPELD.EQ.5) GO TO 460
      IF(DABS(FT).LE.1.0D-6) GO TO 465
      GO TO 462
C
  460 IF(FT.LE.1.0D-6) 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*SZ + XI1/3.0
      STRESS(4)=GAMMA*SXY
      STRESS(5)=GAMMA*SXZ
      STRESS(6)=GAMMA*SYZ
      XI1=STRESS(1) + STRESS(2) + STRESS(3)
C
C     UPDATE CAP POSITION *
C
  465 XI1AD=XI1
C
C     UPDATE TEPS(I) *
C
      DO 468 I=1,6
  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,6
      SIG(I)=STRESS(I)
  710 EPS(I)=STRAIN(I)
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,6
      DO 745 J=1,6
  745 C(I,J)=0.0
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=B1
      C(2,1)=B1
      C(2,2)=A1
      C(2,3)=B1
      C(3,1)=B1
      C(3,2)=B1
      C(3,3)=A1
      C(4,4)=C1
      C(5,5)=C1
      C(6,6)=C1
C
      RETURN
C
C     DRUCKER-PRAGER (INCLUDING DRUCKER-PRAGER AT VERTEX, IPEL=2,3) **
C
  750 CALL PRAG3(DEPS,IPELD)
C
      RETURN
C
C     VERTEX (IPEL=4) **
C
  760 VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
     1       + STRESS(3))
      CALL VERT3(DEPS,VPSTR)
C
      RETURN
C
C     CAP (IPEL=5) **
C
  770 VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
     1       + STRESS(3))
      CALL CAP3(DEPS,VPSTR)
C
      RETURN
C
C        13. PRINTING OF STRESSES AND STRAINS
C
  800 CALL DEVST3 (STRESS,SS,XI1,XJ2)
      FT=ALFA*XI1 + DSQRT(XJ2) - XK
C
C     CALCULATE PLASTIC STRAINS **
C
      EPSP(1)=STRAIN(1) - (A1I*STRESS(1) + B1I*(STRESS(2) + STRESS(3)))
      EPSP(2)=STRAIN(2) - (A1I*STRESS(2) + B1I*(STRESS(1) + STRESS(3)))
      EPSP(3)=STRAIN(3) - (A1I*STRESS(3) + B1I*(STRESS(1) + STRESS(2)))
      EPSP(4)=STRAIN(4) - C1I*STRESS(4)
      EPSP(5)=STRAIN(5) - C1I*STRESS(5)
      EPSP(6)=STRAIN(6) - C1I*STRESS(6)
C
  810 IF (IPRI.NE.0) RETURN
      IDUM=1
      IF(IPELD.GT.1.AND.IPELD.LT.6) IDUM=2
      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(J),J=1,6)
      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(J),J=1,6)
      WRITE (6,2400) (STRAIN(J),J=1,6)
      WRITE (6,2500) (EPSP(J),J=1,6)
      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,2HXY,13X,2HXZ,13X,2HYZ,/,
     2        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))
 2200 FORMAT (20X,7HIPEL = ,I2,2X,15HCAP POSITION = ,E14.6,2X,
     1        21HD-P YIELD FUNCTION = ,E14.6,/)
 2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
 2500 FORMAT (25X,7HPLASTIC,3X,6(E14.6,1X))
C
 3004 FORMAT(87H   ERROR   UNABLE TO OBTAIN VALUE FOR "RATIO" BETWEEN 0.
     10 AND 1.0   (SUBROUTINE DRUCK3)/)
 3005 FORMAT(75H   ERROR   UNABLE TO OBTAIN CORRECT VALUE FOR "RATIO"
     1(SUBROUTINE DRUCK3)/)
C
      END
C *CDC* *DECK PRAG3
C *UNI* )FOR,IS N.PRAG3, R.PRAG3
      SUBROUTINE PRAG3(DEPS,IPELD)
C
C
C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
C     FOR THE DRUCKER-PRAGER YIELD SURFACE (IPEL=2,3)
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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
C
      DIMENSION DP(36),SS(6),DEPS(1)
      EQUIVALENCE (C(1,1),DP(1))
C
C
      CALL DEVST3(STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
C
      QDQ=DSQRT(G + 9.0*BM*ALFA*ALFA)
      AA=G/DSQRT(XJ2)/QDQ
      BB=3.0*BM*ALFA/QDQ
C
      DLAMDA=BB*(DEPS(1) + DEPS(2) + DEPS(3)) + AA*(SX*DEPS(1) +
     1       SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5) +
     2       SYZ*DEPS(6))
      IF(DLAMDA.GT.0.0) GO TO 30
C
      SX=0.0
      SY=0.0
      SZ=0.0
      SXY=0.0
      SXZ=0.0
      SYZ=0.0
      GO TO 40
C
   30 IF(IPELD.NE.3) GO TO 35
      QDQ=DSQRT(G)
      AA=G/DSQRT(XJ2)/QDQ
      BB=0.0
C
   35 SX=AA*SX + BB
      SY=AA*SY + BB
      SZ=AA*SZ + BB
      SXY=AA*SXY
      SXZ=AA*SXZ
      SYZ=AA*SYZ
C
   40 DP(1)=A1 - SX*SX
      DP(2)=B1 - SX*SY
      DP(3)=B1 - SX*SZ
      DP(4)=   - SX*SXY
      DP(5)=   - SX*SXZ
      DP(6)=   - SX*SYZ
C
      DP(7)=DP(2)
      DP(8)=A1 - SY*SY
      DP(9)=B1 - SY*SZ
      DP(10)=   - SY*SXY
      DP(11)=   - SY*SXZ
      DP(12)=   - SY*SYZ
C
      DP(13)=DP(3)
      DP(14)=DP(9)
      DP(15)=A1 - SZ*SZ
      DP(16)=   - SZ*SXY
      DP(17)=   - SZ*SXZ
      DP(18)=   - SZ*SYZ
C
      DP(19)=DP(4)
      DP(20)=DP(10)
      DP(21)=DP(16)
      DP(22)=C1 - SXY*SXY
      DP(23)=   - SXY*SXZ
      DP(24)=   - SXY*SYZ
C
      DP(25)=DP(5)
      DP(26)=DP(11)
      DP(27)=DP(17)
      DP(28)=DP(23)
      DP(29)=C1 - SXZ*SXZ
      DP(30)=   - SXZ*SYZ
C
      DP(31)=DP(6)
      DP(32)=DP(12)
      DP(33)=DP(18)
      DP(34)=DP(24)
      DP(35)=DP(30)
      DP(36)=C1 - SYZ*SYZ
C
      RETURN
      END
C *CDC* *DECK VERT3
C *UNI* )FOR,IS  N.VERT3, R.VERT3
      SUBROUTINE VERT3(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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
C
      DIMENSION VP(36),SS(6),DEPS(1)
      EQUIVALENCE (C(1,1),VP(1))
C
C
      CALL DEVST3(STRESS,SS,DUM1,XJ2)
      SX=SS(1)
      SY=SS(2)
      SZ=SS(3)
      SXY=SS(4)
      SXZ=SS(5)
      SYZ=SS(6)
C
      QDQ=DSQRT(G + 9.0*BM*ALFA*ALFA)
      AA=G/XJ2/QDQ
      BB=3.0*BM*ALFA/QDQ
      CC=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC-VPSTR)))
C
      DLAMD=BB*(DEPS(1) + DEPS(2) + DEPS(3)) + AA*(SX*DEPS(1) +
     1      SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5) +
     2      SYZ*DEPS(6))
      DLAMC=-DEPS(1) - DEPS(2) - DEPS(3)
      IF(DLAMD.GT.0.0.AND.DLAMC.GT.0.0) GO TO 30
C
      CC=0.0
      SX=0.0
      SY=0.0
      SZ=0.0
      SXY=0.0
      SXZ=0.0
      SYZ=0.0
      GO TO 35
C
   30 SX=AA*SX + BB
      SY=AA*SY + BB
      SZ=AA*SZ + BB
      SXY=AA*SXY
      SXZ=AA*SXZ
      SYZ=AA*SYZ
C
   35 VP(1)=A1 - SX*SX - CC
      VP(2)=B1 - SX*SY - CC
      VP(3)=B1 - SX*SZ - CC
      VP(4)=   - SX*SXY
      VP(5)=   - SX*SXZ
      VP(6)=   - SX*SYZ
C
      VP(7)=VP(2)
      VP(8)=A1 - SY*SY - CC
      VP(9)=B1 - SY*SZ - CC
      VP(10)=  -SY*SXY
      VP(11)=  -SY*SXZ
      VP(12)=  - SY*SYZ
C
      VP(13)=VP(3)
      VP(14)=VP(9)
      VP(15)=A1 - SZ*SZ - CC
      VP(16)=   - SZ*SXY
      VP(17)=   - SZ*SXZ
      VP(18)=   - SZ*SYZ
C
      VP(19)=VP(4)
      VP(20)=VP(10)
      VP(21)=VP(16)
      VP(22)=C1 - SXY*SXY
      VP(23)=   - SXY*SXZ
      VP(24)=   - SXY*SYZ
C
      VP(25)=VP(5)
      VP(26)=VP(11)
      VP(27)=VP(17)
      VP(28)=VP(23)
      VP(29)=C1 - SXZ*SXZ
      VP(30)=   - SXZ*SYZ
C
      VP(31)=VP(6)
      VP(32)=VP(12)
      VP(33)=VP(18)
      VP(34)=VP(24)
      VP(35)=VP(30)
      VP(36)=C1 - SYZ*SYZ
C
      RETURN
      END
C *CDC* *DECK CAP3
C *UNI* )FOR,IS N.CAP3, R,CAP3
      SUBROUTINE CAP3(DEPS,VPSTR)
C
C
C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
C     FOR THE CAP (IPEL=5)
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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
C
      DIMENSION CP(36),DEPS(1)
      EQUIVALENCE (C(1,1),CP(1))
C
C
      GAMMA=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC-VPSTR)))
      DLAMDA=-DEPS(1) - DEPS(2) - DEPS(3)
      IF(DLAMDA.GT.0.0) GO TO 30
C
      CP1=A1
      CP2=B1
      GO TO 35
C
   30 CP1=A1 - GAMMA
      CP2=B1 - GAMMA
C
   35 DO 40 J=1,36
   40 CP(J)=0.0
C
      CP(1)=CP1
      CP(2)=CP2
      CP(3)=CP2
      CP(7)=CP2
      CP(8)=CP1
      CP(9)=CP2
      CP(13)=CP2
      CP(14)=CP2
      CP(15)=CP1
      CP(22)=C1
      CP(29)=C1
      CP(36)=C1
C
      RETURN
      END
C *CDC* *DECK DEVST3
C *UNI* )FOR,IS  N.DEVST3, R.DEVST3
      SUBROUTINE DEVST3(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(6),DSTRS(6)
C
C
      SM=STRESS(1) + STRESS(2) + STRESS(3)
      XI1=SM
      SM=SM/3.0
C
      DSTRS(1)=STRESS(1) - SM
      DSTRS(2)=STRESS(2) - SM
      DSTRS(3)=STRESS(3) - SM
      DSTRS(4)=STRESS(4)
      DSTRS(5)=STRESS(5)
      DSTRS(6)=STRESS(6)
C
      XJ2=0.5*(DSTRS(1)*DSTRS(1) + DSTRS(2)*DSTRS(2) +
     1    DSTRS(3)*DSTRS(3)) + (DSTRS(4)*DSTRS(4) + DSTRS(5)*DSTRS(5)
     2    + DSTRS(6)*DSTRS(6))
C
      RETURN
      END
C *CDC* *DECK OVL45
C *CDC*       OVERLAY (ADINA,4,5)
C *CDC* *DECK ELT3D8
C *UNI* )FOR,IS  N.ELT3D8, R.ELT3D8
C *CDC*       PROGRAM ELT3D8
      SUBROUTINE ELT3D8
C
C
C                M O D E L S = 8 AND 9
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      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 /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DPR/ ITWO
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ),(NPAR(17),NCON)
C
      IDW=21*ITWO
      NPT=NINT*NINT*NINTZ
      MATP=IA(N107 + NEL - 1)
      NM=N111 + (MATP - 1)*NCON*ITWO
      NN=N112 + (NEL-1) * NPT * IDW
C
      IF (IND.NE.0) GO TO 100
C
C     I N I T I A L I Z E   W O R K I N G   A R R A Y   (WA)
C
      CALL IELP3 (A(NN),A(NN),A(NM),NPT,IDW)
      GO TO 599
C
C     C A L C U L A T E   S T R E S S E S   A N D
C     S T R E S S  -  S T R A I N   L A W
C
  100 NS=NN + (IPT-1) * IDW
      CALL ELPAL3 (A(NM),A(NS),A(NS + 6*ITWO),A(NS + 12*ITWO),
     1             A(NS + 18*ITWO),A(NS + 19*ITWO),A(NS + 20*ITWO))
  599 CONTINUE
      RETURN
      END
C *CDC* *DECK IELP3
C *UNI* )FOR,IS  N.IELP3,  R.IELP3
      SUBROUTINE IELP3 (WA,IWA,PROP,NPT,IDW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DPR/ ITWO
      DIMENSION WA(21,1),IWA(IDW,1),PROP(1)
C
      DO 25 J=1,NPT
C
      DO 15 I=1,19
      WA(I,J)=0.
   15 CONTINUE
C
      WA(20,J)=(PROP(3)**2)/3.
      KJ=20*ITWO + 1
      IWA(KJ,J)=1
C
   25 CONTINUE
C
      RETURN
      END
C *CDC* *DECK ELPAL3
C *UNI* )FOR,IS  N.ELPAL3, R.ELPAL3
      SUBROUTINE ELPAL3 (PROP,SIG,EPS,ALFA,EPSTR,YIELD,IPEL)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   THIS SUBROUTINE CALCULATES THE STRESSES AND STRESS-STRAIN LAW   .
C .   FOR THE FOLLOWING 3-DIM MATERIAL MODELS -                       .
C .                                                                   .
C .      MODEL=9  (MOD=1)    ELASTIC-PLASTIC WITH KINEMATIC HARDENING .
C .      MODEL=8  (MOD=2)    ELASTIC-PLASTIC WITH ISOTROPIC 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 TOLERATED VALUE USED HERE IS THAT THE EQUIVALENT STRESS  .
C .      SHOULD BE WITHIN ONE-HALF PERCENT OF THE YIELD STRESS IN     .
C .      SIMPLE TENSION.                                              .
C .                                                                   .
C .                                                                   .
C .   THE FOLLOWING VARIABLES ARE USED IN THIS SUBROUTINE -           .
C .                                                                   .
C .      SIG     PREVIOUS STRESSES                                    .
C .      EPS     PREVIOUS STRAINS                                     .
C .                                                                   .
C .      STRESS  CURRENT STRESSES (TO BE CALCULATED)                  .
C .      STRAIN  CURRENT STRAINS  (G I V E N)                         .
C .              (STRAIN INCREMENT IN ULJ FORMULATION)                .
C .      EPSP    CURRENT PLASTIC STRAINS                              .
C .      EPSTR   ACCUMULATED EFFECTIVE PLASTIC STRAIN                 .
C .                                                                   .
C .      FTA     (CURRENT EQUIVALENT STRESS ** 2) / 3.                .
C .      YIELD   INITIALIZED TO (PROP(3)**2)/3.                       .
C .              UPDATED TO EQUAL FTA FOR ISOTROPIC HARDENING CASE    .
C .      FTB     = YIELD                                              .
C .                                                                   .
C .      IPEL    = 1, MATERIAL ELASTIC (INITIAL VALUE)                .
C .              = 2, MATERIAL PLASTIC                                .
C .                                                                   .
C .      ALFA    TRANSLATION OF YIELD SURFACE IN STRESS SPACE         .
C .      DEPS    STRAIN INCREMENT FOR EACH STEP OF INTEGRATION        .
C .      TEPS    TOTAL STRAINS ACCOUNTED FOR DURING INTEGRATION       .
C .                                                                   .
C .      DELEPS  INCREMENTAL STRAINS                                  .
C        DELSIG  INCREMENTAL STRESSES, CALCULATED ON THE ASSUMPTION   .
C .              OF ELASTIC BEHAVIOR DURING STRAIN INCREMENT (DELEPS) .
C .                                                                   .
C .      ICOR    NO. OF TIMES CORRECTION IS APPLIED (APPLICABLE       .
C .              ONLY FOR THE PERFECTLY PLASTIC CASE)                 .
C .      INTER   NO. OF INCREMENT INTERVALS  (MAX=25)                 .
C .                                                                   .
C .      PROP(1) YOUNGS MODULUS                                       .
C .      PROP(2) POISSONS RATIO                                       .
C .                                                                   .
C .      BILINEAR STRESS-STRAIN CURVE                                 .
C .                                                                   .
C .      PROP(3) INITIAL YIELD STRESS IN TENSION                      .
C .      PROP(4) 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 . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
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 /MTMD3D/ D(36),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DISDR/ DISD(9)
C
      COMMON /MISES/ A1,B1,C1,A3,A1I,B1I,C1I,BET,CEE,DEPS(6),DEPSP(6),
     1               TEPS(6),ALFAD(6),HP,FTB,XCON1,XCON2,MOD
      COMMON /PSTCH/ STRCH(3),RDCS(3)
C
      DIMENSION DELSIG(6),DELEPS(6),STATE(2),IMODEL(2)
      DIMENSION PROP(1),SIG(1),EPS(1),ALFA(1),EPSP(6)
C
      EQUIVALENCE (NPAR(17),NCON)
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(3),INDNL)
      DATA STATE /2H E,2H*P/, IMODEL /2, 1/
C
C
      YIELDD=YIELD
      IPELD=IPEL
      EPSTRD=EPSTR
      ICOR=0
      INTER=0
C
      DO 50 I=1,6
      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
C
C     .....  CALCULATION OF MATERIAL CONSTANTS   ......................
C
      A1=YM/(1.+PV)
      A3=A1
      C1=A1/2.
      A1=A1/(1.-2.*PV)
      B1=A1*PV
      A1=A1-B1
C
      A1I=1.0/YM
      B1I=-PV/YM
      C1I=1.0/C1
C
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 HARDM3 (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     .....  DETERMINATION OF STATE OF STRESS  ........................
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,6
  120 DELEPS(I)=STRAIN(I) - EPS(I)
      GO TO 130
C
  121 DO 122 I=1,6
  122 DELEPS(I)=STRAIN(I)
      GO TO 145
C
  130 EPSP(1)=EPS(1) - (A1I*SIG(1) + B1I*(SIG(2) + SIG(3)))
      EPSP(2)=EPS(2) - (A1I*SIG(2) + B1I*(SIG(1) + SIG(3)))
      EPSP(3)=EPS(3) - (A1I*SIG(3) + B1I*(SIG(1) + SIG(2)))
      EPSP(4)=EPS(4) - C1I*SIG(4)
      EPSP(5)=EPS(5) - C1I*SIG(5)
      EPSP(6)=EPS(6) - C1I*SIG(6)
C
C        2. CALCULATE INCREMENTAL STRESSES,
C           ASSUMING ELASTIC BEHAVIOR
C
  145 DELSIG(1)=A1*DELEPS(1) + B1*(DELEPS(2) + DELEPS(3))
      DELSIG(2)=A1*DELEPS(2) + B1*(DELEPS(1)+DELEPS(3))
      DELSIG(3)=A1*DELEPS(3) + B1*(DELEPS(1)+DELEPS(2))
      DELSIG(4)=C1*DELEPS(4)
      DELSIG(5)=C1*DELEPS(5)
      DELSIG(6)=C1*DELEPS(6)
C
C        3. WITH THE ASSUMPTION OF ELASTIC BEHAVIOR DURING
C           THIS INCREMENT, DETERMINE WHERE THE NEW STATE OF
C           STRESS FALLS IN THE STRESS SPACE
C
      DM=(DELSIG(1)+DELSIG(2)+DELSIG(3))/3.
      DX=DELSIG(1) - DM
      DY=DELSIG(2) - DM
      DZ=DELSIG(3) - DM
C
C
      SM=(SIG(1)+SIG(2)+SIG(3))/3.
      SXX=SIG(1) - SM
      SYY=SIG(2) - SM
      SZZ=SIG(3) - SM
      SXY=SIG(4)
      SXZ=SIG(5)
      SYZ=SIG(6)
C
      IF (MOD.EQ.2) GO TO 150
C
C
      SXX=SXX - ALFAD(1)
      SYY=SYY - ALFAD(2)
      SZZ=SZZ - ALFAD(3)
      SXY=SXY - ALFAD(4)
      SXZ=SXZ - ALFAD(5)
      SYZ=SYZ - ALFAD(6)
C
  150 RA=.5 * (DX**2 + DY**2 + DZ**2) + DELSIG(4)**2 + DELSIG(5)**2
     1   + DELSIG(6)**2
      RB=SXX*DX + SYY*DY +SZZ*DZ +
     1   2. * (SXY*DELSIG(4) + SXZ*DELSIG(5) + SYZ*DELSIG(6))
C
      RD=FTB
      IF (IPELD.EQ.2) GO TO 160
      RD=.5*(SXX**2 + SYY**2 + SZZ**2) + SXY**2 + SXZ**2 + SYZ**2
C
  160 FTA=RA + RB + RD
C
C     RA = 0  IMPLIES PURE HYDROSTATIC LOADING
C     ( HENCE, IPELD STAYS CONSTANT )
C
      IF (RA .EQ. 0.0) GO TO 175
C
      IF (FTA-FTB) 170,170,300
C
C
C     WITH THE ASSUMPTION OF ELASTIC BEHAVIOR, STATE OF STRESS FALLS
C     WITHIN OR ON THE (CURRENT) YIELD SURFACE - E L A S T I C
C
  170 IPELD=1
C
  175 DO 176 I=1,6
  176 STRESS(I)=SIG(I) + DELSIG(I)
      GO TO 520
C
C
C     WITH THE ASSUMPTION OF ELASTIC BEHAVIOR, STATE OF STRESS FALLS
C     OUTSIDE THE (CURRENT) YIELD SURFACE - P L A S T I C
C
  300 IPELD=2
C
C
C     ...  DETERMINATION OF PART OF STRAIN TAKEN ELASTICALLY (RATIO) ..
C
      RC=RD - FTB
      RATIO= (-RB + DSQRT(RB**2 - 4.*RA*RC)) / (2.*RA)
      DO 320 I=1,6
  320 STRESS(I)=SIG(I) + RATIO*DELSIG(I)
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,6
  380 DEPS(I)=XM * DELEPS(I)
C
C
C     .....  CALCULATION OF ELASTIC-PLASTIC STRESSES  .....(START).....
C
      DO 550 IN=1,INTER
C
      CALL MIDEP3
C
      DO 420 I=1,6
      J=6*(I-1)
C
      STRESS(I)=STRESS(I) + D(J+1)*DEPS(1) + D(J+2)*DEPS(2)
     1                    + D(J+3)*DEPS(3) + D(J+4)*DEPS(4)
     2                    + D(J+5)*DEPS(5) + D(J+6)*DEPS(6)
C
  420 CONTINUE
C
C     UPDATE PLASTIC STRAINS AND ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
      DO 425 I=1,6
  425 EPSP(I)=EPSP(I) + DEPSP(I)
C
      DEPSTR=DSQRT(XCON1*(DEPSP(1)*DEPSP(1) + DEPSP(2)*DEPSP(2) +
     1            DEPSP(3)*DEPSP(3)) + XCON2*(DEPSP(4)*DEPSP(4) +
     2            DEPSP(5)*DEPSP(5) + DEPSP(6)*DEPSP(6)))
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(3)=ALFAD(3) + CEE*DEPSP(3)
      ALFAD(4)=ALFAD(4) + 0.5*CEE*DEPSP(4)
      ALFAD(5)=ALFAD(5) + 0.5*CEE*DEPSP(5)
      ALFAD(6)=ALFAD(6) + 0.5*CEE*DEPSP(6)
C
      GO TO 500
C
  440 SM=(STRESS(1)+STRESS(2)+STRESS(3))/3.
      SX=STRESS(1) - SM
      SY=STRESS(2) - SM
      SZ=STRESS(3) - SM
      FTA=.5 * (SX**2 + SY**2 + SZ**2) +
     1    STRESS(4)**2 + STRESS(5)**2 + STRESS(6)**2
C
      IF (ET.NE.0.0) GO TO 500
C
C     PERFECTLY PLASTIC MATERIAL  -  APPLY CORRECTION (IF NECESSARY)
C
  480 FTR=DSQRT(FTA/FTB)
C
C     CORRECTION
C
      ICOR=ICOR + 1
      COEF=-1. + (1./FTR)
C
      STRESS(1)=STRESS(1) + COEF*SX
      STRESS(2)=STRESS(2) + COEF*SY
      STRESS(3)=STRESS(3) + COEF*SZ
C
      COEF= 1. + COEF
      STRESS(4)=STRESS(4)*COEF
      STRESS(5)=STRESS(5)*COEF
      STRESS(6)=STRESS(6)*COEF
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 HARDM3 (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     .....  CALCULATION OF ELASTIC-PLASTIC STRESSES  .....(E N D).....
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
  520 IF (INDNL.NE.3) GO TO 600
      OMEGA1=DISD(4) - DISD(6)
      OMEGA2=DISD(5) - DISD(8)
      OMEGA3=DISD(7) - DISD(9)
      STRESS(1)=STRESS(1) + SIG(4)*OMEGA1 + SIG(5)*OMEGA2
      STRESS(2)=STRESS(2) - SIG(4)*OMEGA1 + SIG(6)*OMEGA3
      STRESS(3)=STRESS(3) - SIG(5)*OMEGA2 - SIG(6)*OMEGA3
      STRESS(4)=STRESS(4) + 0.5*(OMEGA1*(SIG(2) - SIG(1)) +
     1                      OMEGA3*SIG(5) + OMEGA2*SIG(6))
      STRESS(5)=STRESS(5) + 0.5*(OMEGA2*(SIG(3) - SIG(1)) +
     1                      OMEGA1*SIG(6) - OMEGA3*SIG(4))
      STRESS(6)=STRESS(6) + 0.5*(OMEGA3*(SIG(3) - SIG(2)) -
     1                      OMEGA2*SIG(4) - OMEGA1*SIG(5))
C
C     U P D A T I N G
C
C
  600 IF (IUPDT.NE.0) GO TO 615
      YIELD=YIELDD
      IPEL=IPELD
      EPSTR=EPSTRD
      DO 610 I=1,6
      ALFA(I)=ALFAD(I)
      SIG(I)=STRESS(I)
  610 EPS(I)=STRAIN(I)
C
  615 IF (KPRI.EQ.0) GO TO 700
C
      IF (ICOUNT.EQ.3) RETURN
C
C
C     .....  CALCULATION OF STRESS - STRAIN LAW  ......................
C
C
C     IN DIVERGENCE REFORMATION (IEQREF=1), ASSUME ELASTIC BEHAVIOR
C
      IF (IEQREF.EQ.1) GO TO 624
      IF (IPELD.EQ.2) GO TO 650
C
  624 DO 625 I=1,36
  625 D(I)=0.
C
      D( 1)=A1
      D( 8)=A1
      D(15)=A1
C
      D( 2)=B1
      D( 3)=B1
      D( 7)=B1
      D( 9)=B1
      D(13)=B1
      D(14)=B1
C
      D(22)=C1
      D(29)=C1
      D(36)=C1
C
      RETURN
C
C
  650 CALL MIDEP3
C
      RETURN
C
C
C     PRINTING OF STRESSES
C
  700 SM=(STRESS(1) + STRESS(2) + STRESS(3))/3.0
      SX=STRESS(1) - SM
      SY=STRESS(2) - SM
      SZ=STRESS(3) - SM
      SXY=STRESS(4)
      SXZ=STRESS(5)
      SYZ=STRESS(6)
C
      IF (MOD.EQ.2) GO TO 710
      SX=SX - ALFAD(1)
      SY=SY - ALFAD(2)
      SZ=SZ - ALFAD(3)
      SXY=SXY - ALFAD(4)
      SXZ=SXZ - ALFAD(5)
      SYZ=SYZ - ALFAD(6)
C
  710 FTA=.5 * (SX*SX + SY*SY + SZ*SZ) + SXY*SXY + SXZ*SXZ + SYZ*SYZ
      YIELDD=DSQRT(3.*YIELDD)
      FT=DSQRT(3.*FTA)
C
      IF (INDNL.NE.2) GO TO 800
C
C     IN TOTAL LAGRANGIAN FORMULATION CALCULATE CAUCHY STRESSES
C
      CALL CAUCH3
C
  800 IF (IPRI.NE.0) RETURN
      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(J),J=1,6),INTER,ICOR
      WRITE (6,2200) FT,YIELDD,EPSTRD
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(J),J=1,6),INTER,ICOR
C
      IF (INDNL.EQ.3) GO TO 880
C
      WRITE (6,2400) (STRAIN(J),J=1,6)
      WRITE (6,2500) (EPSP(J),J=1,6)
      WRITE (6,2200) FT,YIELDD,EPSTRD
C
  880 CONTINUE
      WRITE (6,2200) FT,YIELDD,EPSTRD
C
      RETURN
C
 2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,5X,2HXX,13X,
     1        2HYY,13X,2HZZ,13X,2HXY,13X,2HXZ,13X,2HYZ,6X,5HINTER,2X,
     2        4HICOR,/,1X,7HNUM/IPT,2X,5HSTATE,5X,10HCOMPONENTS)
 2005 FORMAT (/,1X,I3)
 2100 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,6X,6(E14.6,1X),1X,I3,
     1        2X,I3)
 2200 FORMAT (20X,19HEFFECTIVE STRESS = ,E14.6,
     1        1X,15HYIELD STRESS = ,E14.6,
     2        1X,29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/)
 2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
 2500 FORMAT (25X,7HPLASTIC,3X,6(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
C *CDC* *DECK MIDEP3
C *UNI* )FOR,IS  N.MIDEP3, R.MIDEP3
      SUBROUTINE MIDEP3
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MTMD3D/ DP(36),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /MISES/ A1,B1,C1,A3,A1I,B1I,C1I,BET,CEE,DEPS(6),DEPSP(6),
     1               TEPS(6),ALFA(6),HP,FTB,XCON1,XCON2,MOD
C
      SM=(STRESS(1)+STRESS(2)+STRESS(3))/3.
      SXX=STRESS(1) - SM
      SYY=STRESS(2) - SM
      SZZ=STRESS(3) - SM
      SXY=STRESS(4)
      SXZ=STRESS(5)
      SYZ=STRESS(6)
C
      IF (MOD.EQ.2) GO TO 20
C
      SXX=SXX - ALFA(1)
      SYY=SYY - ALFA(2)
      SZZ=SZZ - ALFA(3)
      SXY=SXY - ALFA(4)
      SXZ=SXZ - ALFA(5)
      SYZ=SYZ - ALFA(6)
C
   20 WP=SXX*DEPS(1) + SYY*DEPS(2) + SZZ*DEPS(3) +
     1   SXY*DEPS(4) + SXZ*DEPS(5) + SYZ*DEPS(6)
      BETT=BET
C
      IF (WP .LT. 0.0) BETT=0.
C
C     CALCULATE PLASTIC STRAIN INCREMENTS
C
      XLAMDA=(BETT/(2.*C1))*WP
      DEPSP(1)=XLAMDA*SXX
      DEPSP(2)=XLAMDA*SYY
      DEPSP(3)=XLAMDA*SZZ
      DEPSP(4)=2.0*XLAMDA*SXY
      DEPSP(5)=2.0*XLAMDA*SXZ
      DEPSP(6)=2.0*XLAMDA*SYZ
C
C
      BETA=BETT*SXX
      DP( 1)=A1 - BETA*SXX
      DP( 2)=B1 - BETA*SYY
      DP( 3)=B1 - BETA*SZZ
      DP( 4)=   - BETA*SXY
      DP( 5)=   - BETA*SXZ
      DP( 6)=   - BETA*SYZ
C
      BETA=BETT*SYY
      DP( 7)=DP( 2)
      DP( 8)=A1 - BETA*SYY
      DP( 9)=B1 - BETA*SZZ
      DP(10)=   - BETA*SXY
      DP(11)=   - BETA*SXZ
      DP(12)=   - BETA*SYZ
C
      BETA=BETT*SZZ
      DP(13)=DP( 3)
      DP(14)=DP( 9)
      DP(15)=A1 - BETA*SZZ
      DP(16)=   - BETA*SXY
      DP(17)=   - BETA*SXZ
      DP(18)=   - BETA*SYZ
C
      BETA=BETT*SXY
      DP(19)=DP( 4)
      DP(20)=DP(10)
      DP(21)=DP(16)
      DP(22)=C1 - BETA*SXY
      DP(23)=   - BETA*SXZ
      DP(24)=   - BETA*SYZ
C
      BETA=BETT*SXZ
      DP(25)=DP( 5)
      DP(26)=DP(11)
      DP(27)=DP(17)
      DP(28)=DP(23)
      DP(29)=C1 - BETA*SXZ
      DP(30)=   - BETA*SYZ
C
      BETA=BETT*SYZ
      DP(31)=DP( 6)
      DP(32)=DP(12)
      DP(33)=DP(18)
      DP(34)=DP(24)
      DP(35)=DP(30)
      DP(36)=C1 - BETA*SYZ
C
C
C
      RETURN
      END
C *CDC* *DECK HARDM3
C *UNI* )FOR,IS N.HARDM3, R.HARDM3
C
      SUBROUTINE HARDM3 (PROP,EPSTR,ET)
C
C
C
C     THIS SUBROUTINE CALCULATES THE SLOPE OF THE UNIAXIAL
C     STRESS-STRAIN CURVE CORRESPONDING TO A GIVEN VALUE
C     OF ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
C
C
C        NPR  = NUMBER OF PAIRS OF STRESS-STRAIN VALUES DEFINING THE
C               PLASTIC PORTION OF THE STRESS-STRAIN CURVE
C        NSEG = NUMBER OF SEGMENTS IN THE PLASTIC PORTION OF THE CURVE
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      DIMENSION PROP(1)
      EQUIVALENCE (NPAR(17),NCON)
C
C
      YM=PROP(1)
      NPR=(NCON - 2)/2
      NSEG=NPR - 1
C
      KK=6
      DO 10 J=1,NSEG
      TEPSTR=PROP(KK) - (PROP(KK - 1)/YM)
      IF (EPSTR.LT.TEPSTR) GO TO 20
   10 KK=KK + 2
C
      WRITE (6,2000)
      STOP
C
C     CALCULATE THE HARDENING MODULUS
C
   20 ET=(PROP(KK - 1) - PROP(KK - 3))/(PROP(KK) - PROP(KK - 2))
C
      RETURN
C
 2000 FORMAT (126H   ERROR   ACCUMULATED EFFECTIVE PLASTIC STRAIN IS OUT
     1SIDE THE RANGE OF THE UNIAXIAL STRESS-STRAIN CURVE   (SUBROUTINE H
     2ARDM3))
C
      END
C *CDC* *DECK OVL46
C *CDC*       OVERLAY(ADINA,4,6)
C *CDC* *DECK EL3D10
C *UNI* )FOR,IS  N.EL3D10, R.EL3D10
C *CDC*       PROGRAM  EL3D10
C
      SUBROUTINE EL3D10
C
C
C
C     THERMOELASTIC/PLASTIC/CREEP MATERIAL MODEL
C        MODEL = 10  (ISOTROPIC HARDENING, VON MISES YIELD CRITERION)
C        MODEL = 11  (KINEMATIC HARDENING, VON MISES YIELD CRITERION)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /DPR/ ITWO
      COMMON A(1)
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
C
      REAL A
C
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT),(A(1),IA(1)),(NPAR(17),NCON),
     1            (NPAR(7),MXNODS),(NPAR(11),NINTZ)
C
C
C
C     FOR ADDRESSES N101,N102,..........SEE SUBROUTINE THREDM
C
C     QUANTITIES STORED FOR EACH INTEGRATION POINT
C
C        STRESS COMPONENTS
C        TOTAL STRAIN COMPONENTS
C        PLASTIC STRAIN COMPONENTS
C        CREEP STRAIN COMPONENTS
C        YIELD STRESS
C        ACCUMULATED INCREMENTS OF EFFECTIVE PLASTIC STRAIN
C        YIELD SURFACE TRANSLATION COMPONENTS
C        ORIGINS FOR O.R.N.L. CYCLIC CREEP
C        TEMPERATURE
C        IPEL AND NORG
C        IPEL = 1 THERMO-ELASTIC AND CREEP BEHAVIOR
C             = 2 THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR
C        NORG = 1 POSITIVE ORIGIN
C             = 2 NEGATIVE ORIGIN
C
C     QUANTITIES STORED FOR EACH ELEMENT
C
C        GLOBAL NODAL POINT NUMBERS
C
C
C
      IDW=47*ITWO
      NPT=NINT*NINT*NINTZ
C
C        1. DETERMINE MATERIAL PROPERTY SET NUMBER
C
      MATP=IA(N107 + NEL - 1)
C
C        2. DETERMINE MATERIAL PROPERTY SET LOCATIONS
C
      NM=N111 + (MATP - 1)*NCON*ITWO
C
C        3. INITIALIZE WORKING ARRAY
C
      IF(IND.NE.0) GO TO 100
      NN=N112+(NEL-1)*(IDW*NPT+MXNODS)
      CALL IEPC3(A(NN),A(NN + IDW*NPT),A(NN),IDW,A(N6A + ITWO),A(NM))
      GO TO 200
C
C        4. DETERMINE LOCATIONS OF VARIABLES IN WORKING ARRAY
C
  100 NN=N112+(NEL-1)*(IDW*NPT+MXNODS)+(IPT-1)*IDW
      NN1=NN
      NN2=NN+6*ITWO
      NN3=NN+12*ITWO
      NN4=NN+18*ITWO
      NN5=NN+24*ITWO
      NN6=NN+25*ITWO
      NN7=NN + 26*ITWO
      NN8=NN + 32*ITWO
      NN9=NN + 44*ITWO
      NN10=NN + 45*ITWO
      NN11=NN + 46*ITWO
C
C        5. DETERMINE ELEMENT GLOBAL NODAL POINT NUMBERS LOCATION
C
      KK=N112+(NEL-1)*(IDW*NPT+MXNODS)+IDW*NPT
C
C        6. DETERMINE MIDSIDE NODE ARRAY LOCATION
C
      ND9DIM=MXNODS-8
      LL=N108+(NEL-1)*ND9DIM
C
C        7. CALCULATE STRESSES AND CONSTITUTIVE LAW
C
      CALL EPC3(A(NM),A(NN1),A(NN2),A(NN3),A(NN4),A(NN5),A(NN6),A(NN7),
     1          A(NN8),A(NN9),A(NN10),A(NN11),A(KK),A(LL),A(N6A + ITWO),
     2          A(N6B + ITWO))
C
  200 CONTINUE
C
      RETURN
      END
C *CDC* *DECK IEPC3
C *UNI* )FOR,IS  N.IEPC3, R.IEPC3
C
      SUBROUTINE IEPC3(WA,IWA,IIWA,IIDW,TEMPV1,PROP)
C
C
C
C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR
C     THE THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
C     (MODELS = 10 AND 11)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /DPR/ ITWO
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
      COMMON /SOLPM3/ 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
C
      DIMENSION WA(47,1),IWA(1),IIWA(IIDW,1),TEMPV1(1),H(21),
     1          XDM1(3,21),XDM2(3,3),XDM3(3,1),PROP(16,1),PROP1(5)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ)
C
      NPT=NINT*NINT*NINTZ
      IINTP=1
      NPTS=IDINT(PROP(9,7))
      TOLMT=1.0D-2
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C        1. SET ALL FLOATING-POINT VARIABLES IN THE WORKING ARRAY
C           TO ZERO
C
   15 DO 20 J=1,NPT
      DO 20 I=1,45
   20 WA(I,J)=0.0
C
C        2. STORE GLOBAL NODAL POINT NUMBERS
C
      II=0
      DO 25 K=1,21
      IF(NODM(K).EQ.0) GO TO 25
      II=II+1
      IWA(II)=NODM(K)
   25 CONTINUE
C
C        3. INTERPOLATE INITIAL TEMPERATURE DISTRIBUTION
C           STORE INITIAL INTEGRATION POINT TEMPERATURES
C
      IPT=0
      DO 30 LX=1,NINT
      E1=XG(LX,NINT)
      DO 30 LY=1,NINT
      E2=XG(LY,NINT)
      DO 30 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      IPT=IPT+1
      CALL FUNCT(E1,E2,E3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
      TEMP1=0.0
      DO 35 K=1,IEL
      KK=IWA(K)
   35 TEMP1=TEMP1+H(K)*TEMPV1(KK)
      WA(45,IPT)=TEMP1
C
C        4. INITIALIZE AND STORE YIELD STRESS
C
      CALL MTITP3(PROP,TEMP1,PROP1)
      YS1=PROP1(3)
   30 WA(25,IPT)=YS1
C
C        5. INITIALIZE INTEGER VARIABLES IN THE WORKING ARRAY
C           TO ONE
C
      KJ=45*ITWO + 1
      KJJ=46*ITWO + 1
      DO 40 I=1,NPT
      IIWA(KJ,I)=1
   40 IIWA(KJJ,I)=1
C
      RETURN
C
      END
C *CDC* *DECK EPC3
C *UNI* )FOR,IS  N.EPC3, R.EPC3
C
      SUBROUTINE EPC3(PROP,SIG,EPS,EPSP,EPSC,YLD,EPSTR,ALFA,ORIG,TMPOLD,
     1                IPEL,NORG,NDS,NOD9M,TEMPV1,TEMPV2)
C
C
C
C     THIS SUBROUTINE CALCULATES THE STRESSES, PLASTIC STRAINS,
C     CREEP STRAINS, AND THE CONSTITUTIVE LAW FOR THE
C     THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
C     (MODELS = 10 AND 11)
C
C
C
C     NALG = 1  ALGORITHM USES ISUBM SUBDIVISIONS OF EQUAL SIZE
C
C          = 2  ALGORITHM USES VARIABLE SIZE SUBDIVISIONS UP TO A
C               MAXIMUM OF ISUBM
C
C
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        SIG = STRESSES AT TIME OF LAST UPDATE
C        EPS = TOTAL STRAINS AT TIME OF LAST UPDATE
C        EPSP = PLASTIC STRAINS AT TIME OF LAST UPDATE
C        EPSC = CREEP STRAINS AT TIME OF LAST UPDATE
C        YLD = YIELD STRESS AT TIME OF LAST UPDATE
C        EPSTR = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT TIME OF LAST
C                UPDATE
C        ORIG = ORIGINS FOR O.R.N.L. CYCLIC CREEP AT TIME OF LAST UPDATE
C        ALFA = YIELD SURFACE TRANSLATION COMPONENTS AT TIME OF LAST
C               UPDATE
C        IPEL = ELASTIC-PLASTIC INDICATOR AT TIME OF LAST UPDATE
C        NORG = CYCLIC CREEP ORIGIN INDICATOR AT TIME OF LAST UPDATE
C        TREF = REFERENCE TEMPERATURE
C        KCRP = CREEP LAW NUMBER
C        CRPCON = CREEP LAW COEFFICIENTS
C        XINTP = INTEGRATION PARAMETER
C        ISUBM = MAXIMUM NUMBER OF SUBDIVISIONS
C        NITE = MAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION
C        NALG = ALGORITHM INDICATOR
C        TOLIL,TOL1 = CONVERGENCE TOLERANCES
C        TOL2,TOL5 = ZERO TOLERANCES
C        TOL3,TOL4 = ROUNDOFF TOLERANCES
C        TOL6,TOL7 = YIELD SURFACE TOLERANCES
C        TOLPC = INELASTIC STRAIN TOLERANCE
C        TOLMT = MATERIAL PROPERTY EXTREME TEMPERATURE TOLERANCE
C        DTT = CURRENT TIME STEP
C        DTOD = OLD TIME STEP WHEN USING RESTART
C        DELT = TIME STEP SUBDIVISION
C        STRAIN = TOTAL STRAINS
C        STRESS = STRESSES
C        DELEPS = INCREMENT IN TOTAL STRAINS
C        EPS1 = TOTAL STRAINS AT START OF SUBDIVISION
C        EPS2 = TOTAL STRAINS AT END OF SUBDIVISION
C        DEPS = CHANGE IN TOTAL STRAINS FOR THE SUBDIVISION
C        STRSS1,STRSS2 = STRESSES AT START AND END OF SUBDIVISION
C        STRSSM = WEIGHTED STRESSES
C        DELSIG = CHANGE IN STRESSES FOR THE SUBDIVISION
C        EPST1,EPST2 = THERMAL STRAINS AT START AND END OF SUBDIVISION
C        THSTR1 = THERMAL STRAIN RATE AT START OF SUBDIVISION
C        DPST = CHANGE IN THERMAL STRAINS FOR THE SUBDIVISION
C        EPSC1,EPSC2 = CREEP STRAINS AT START AND END OF SUBDIVISION
C        EPSCM = WEIGHTED CREEP STRAINS
C        DPSC = CHANGE IN CREEP STRAINS FOR THE SUBDIVISION
C        EPSP1,EPSP2 = PLASTIC STRAINS AT START AND END OF SUBDIVISION
C        DPSP = CHANGE IN PLASTIC STRAINS FOR THE SUBDIVISION
C        EPSTR1,EPSTR2 = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT START
C                        AND END OF SUBDIVISION
C        EPSTRM = WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C        TEMP1,TEMP2 = TEMPERATURES AT START AND END OF CURRENT
C                      SOLUTION STEP
C        TMP1,TMP2 = TEMPERATURES AT START AND END OF SUBDIVISION
C        TMPM = WEIGHTED TEMPERATURE
C        ALFA1,ALFA2 = YIELD SURFACE TRANSLATION COMPONENTS AT START
C                      AND END OF SUBDIVISION
C        ALFAM = WEIGHTED YIELD SURFACE TRANSLATION COMPONENTS
C        C = CONSTITUTIVE MATRIX  (ELASTIC OR ELASTIC-PLASTIC)
C        PROP1,PROP2 = MATERIAL PROPERTIES AT START AND END OF
C                      SUBDIVISION
C        PROPM = WEIGHTED MATERIAL PROPERTIES
C        YLD1,YLD2 = YIELD STRESS AT START AND END OF SUBDIVISION
C        YLDM = WEIGHTED YIELD STRESS
C        XLAMDA = LOADING/UNLOADING/NEUTRAL LOADING INDICATOR
C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
      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 /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),Z1,Z2,Z3
      COMMON /SOLPM3/ 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
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
C
      DIMENSION PROP(16,1),SIG(1),EPS(1),EPSC(1),ALFA(1),ORIG(6,1),
     1          ORIGD(6,2),NDS(1),NOD9M(1),TEMPV1(1),TEMPV2(1),
     2          STATE(2),H(21),XDM1(3,21),XDM2(3,3),XDM3(3,1),
     3          DELSIG(6),DELEPS(6),DEPS(6),EPSP1(6),EPSP2(6),
     4          STRSS1(6),STRSS2(6),STRSSM(6),EPSC1(6),EPSC2(6),
     5          EPSCM(6),DPSC(6),ALFA1(6),ALFA2(6),ALFAM(6),
     6          EPS1(6),EPS2(6),PROP1(5),DEPST(6),PROP2(5),PROPM(5)
      DIMENSION STRSSD(6),DPSP(6),EPST2(6),EPSP(1),CEP(6,6),EPST1(6),
     1          DSTSS(6)
C
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(3),INDNL),
     1            (STRESS(1),STRSS2(1))
C
      DATA STATE /2H E,2H*P/
C
C
C
C        1. INITIALIZE SOLUTION PARAMETERS
C
      INDEX=1
      ISUB=1
      ISUBM=IDINT(PROP(13,7))
C
      IF(IPT.GT.1) GO TO 5
C
C     SET TIME STEP SIZE **
C
      DTT=DT
      IF(MODEX.EQ.2.AND.KSTEP.EQ.1.AND.ICOUNT.NE.3.AND.
     1   KPRI.NE.0) DTT=DTOD
C
      SUBDD=5.0
      DTMN=DTT/PROP(13,7)
      IINTP=1
C
      DO 2 J=1,8
    2 CRPCON(J)=PROP(J,7)
C
      NPTS=IDINT(PROP(9,7))
      TREF=PROP(10,7)
      KCRP=IDINT(PROP(11,7))
      XINTP=PROP(12,7)
      NITE=IDINT(PROP(14,7))
      NALG=IDINT(PROP(15,7))
      TOLIL=PROP(16,7)
      TOLPC=PROP(1,8)
C
      XCON1=2.0/3.0
      XCON2=1.0/3.0
C
      ITCHK=1
      IF(NITE.LT.6) ITCHK=0
C
C     SET INTEGRATION PARAMETERS **
C
      XPARM1=1.0 - XINTP
      XPARM2=XINTP
C
C     SET TOLERANCES **
C
      TOL1=TOLIL*TOLIL
      TOL4=5.0D-6
      TOL5=1.0D-20
      TOL2=TOL5*TOL5
      TOL3=2.0*TOL4
      TOL6=0.1
      TOL7=2.0
      TOLMT=1.0D-2
      TCHK=DTT*(1.0 - TOL4)
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C        2. INITIALIZE SOLUTION VARIABLES
C
    5 DO 10 I=1,6
      EPS1(I)=EPS(I)
      EPSP1(I)=EPSP(I)
      EPSP2(I)=EPSP(I)
      ALFA1(I)=ALFA(I)
      ALFA2(I)=ALFA(I)
      EPSC1(I)=EPSC(I)
      EPSC2(I)=EPSC(I)
      DPSC(I)=0.0
      EPST1(I)=0.0
      EPST2(I)=0.0
      DEPST(I)=0.0
      STRSS2(I)=SIG(I)
   10 STRSS1(I)=SIG(I)
C
      YLD1=YLD
      EPSTR1=EPSTR
      EPSTR2=EPSTR
      ECSTR1=0.0
      CRSRM=0.0
      TMP1=TMPOLD
      IPELD=IPEL
      NORGD=NORG
      TAU=0.0
      ESTM=0.0
C
      DO 20 I=1,6
      DO 20 J=1,2
   20 ORIGD(I,J)=ORIG(I,J)
C
C        3. CALCULATE TOTAL STRAIN INCREMENT
C
      DO 25 J=1,6
   25 DELEPS(J)=STRAIN(J) - EPS(J)
C
C        4. CALCULATE TEMPERATURE INCREMENT
C
C     CALCULATE INTEGRATION POINT TEMPERATURES **
C
      CALL FUNCT(Z1,Z2,Z3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
      TEMP1=0.0
      TEMP2=0.0
C
      DO 30 K=1,IEL
      KK=NDS(K)
      TEMP2=TEMP2 + H(K)*TEMPV2(KK)
   30 TEMP1=TEMP1 + H(K)*TEMPV1(KK)
C
      CTEMP=TEMP2
C
C     CHECK FOR START OF A SOLUTION STEP *
C
      IF(ICOUNT.NE.3.AND.KPRI.NE.0) CTEMP=TEMP1
C
      DELTMP=CTEMP - TMPOLD
C
C        5. CALCULATE MATERIAL PROPERTIES AT TIME OF LAST UPDATE
C
      CALL EMAT3(TMPOLD,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
C
      YM1=PROP1(1)
      ET1=PROP1(4)
      YS1=PROP1(3)
C
      EET1=YM1*ET1/(YM1 - ET1)
C
C        6. CALCULATE SIZE OF FIRST SUBDIVISION
C           (STRESS LOOP NO. 1)
C
   40 DELT=DTMN
      IF(KCRP.EQ.0.AND.NALG.EQ.2) DELT=DTT
C
C        7. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
C
   60 XFAC=(TAU + DELT)/DTT
      DO 65 J=1,6
      EPS2(J)=EPS(J) + XFAC*DELEPS(J)
   65 DEPS(J)=EPS2(J) - EPS1(J)
C
C        8. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C
      TMP2=TMPOLD + XFAC*DELTMP
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
      CALL EMAT3(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
C        9. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
C
      ALPHA2=PROP2(5)
C
      EPST2(1)=ALPHA2*(TMP2 - TREF)
      EPST2(2)=EPST2(1)
      EPST2(3)=EPST2(1)
C
C        10. CALCULATE WEIGHTED STRESS
C
      IF(KCRP.EQ.0) GO TO 95
C
   70 DO 75 J=1,6
   75 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
C
C        11. PRELIMINARY CREEP CALCULATIONS
C
      DO 80 J=1,6
   80 DPSC(J)=0.0
      CRSRM=0.0
C
      CALL EFST3(ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,STRSSM)
      IF(ESTM.LE.TOL5.AND.INDEX.GT.1) GO TO 95
C
      DO 90 J=1,6
   90 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
C
      CALL CREEP3(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
     1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,
     2            FF,RR,GG,INDEX,ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        12. CALCULATE THE STRESSES AND CREEP STRAINS AT END OF
C             SUBDIVISION, ASSUMING THERMO-ELASTIC AND CREEP BEHAVIOR
C
   95 CALL SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,DELT,
     2            B2,C2,D2)
C
C        13. CHECK FOR CONVERGENCE OF ITERATION
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ. 0),
C     WHEN KCRP .EQ. 0, OR WHEN XPARM2 .EQ. 0 **
C
  100 IF(KCRP.EQ.0) GO TO 215
      IF(XPARM2.EQ.0.0) GO TO 205
      IF(ITCHK.EQ.1) GO TO 120
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 70
      GO TO 205
C
C     CALCULATE THE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
C     STRESS VECTOR **
C
  120 IF(INDEX - 4) 122,135,125
C
  122 INDEX=INDEX + 1
      GO TO 70
C
  125 DNORM2=0.0
      DO 130 J=1,6
  130 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
C
C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
C
  135 SNORM=0.0
      DO 140 J=1,6
  140 SNORM=SNORM + STRSS2(J)*STRSS2(J)
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 155
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      DO 150 J=1,6
  150 STRSSD(J)=STRSS2(J)
      GO TO 70
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  155 IF(DNORM2.LE.DNORM1) GO TO 185
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 205
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 170
C
      WRITE(6,3004)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
C
  170 INDEX=1
C
      DO 180 I=1,6
      STRSS2(I)=STRSS1(I)
  180 EPSC2(I)=EPSC1(I)
C
      GO TO 60
C
C     FINAL CHECK FOR CONVERGENCE *
C
  185 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 205
C
C     NO CONVERGENCE
C
  190 INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 195
C
      WRITE(6,3001)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  195 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
C
      DO 200 J=1,6
  200 STRSSD(J)=STRSS2(J)
      GO TO 70
C
C        14. CHECK SIZE OF CREEP STRAIN INCREMENT
C
C     CHECK IS BYPASSED WHEN THE MODIFIED EFFECTIVE CREEP STRAIN AT
C     THE START OF THE SUBDIVISION AND/OR THE EFFECTIVE CREEP STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0, OR WHEN KCRP .EQ. 0 **
C
  205 DECSTR=CRSRM*DELT
      IF(DECSTR.LE.TOL5 .OR. ECSTR1.LE.TOL5) GO TO 215
C
      CHECK=DECSTR/(ECSTR1*TOLPC)
      IF(CHECK.LE.1.1) GO TO 215
C
C     CREEP STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 208
C
      WRITE(6,3006)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
C
  208 INDEX=1
C
      DO 210 I=1,6
      EPSC2(I)=EPSC1(I)
  210 STRSS2(I)=STRSS1(I)
C
      GO TO 60
C
C        15. CHECK FOR YIELDING
C
C     DETERMINE LOCATION OF THE STRESS-TEMPERATURE STATE AT END OF
C     SUBDIVISION WITH RESPECT TO THE YIELD SURFACE (ASSUMING NO
C     PLASTICITY) **
C
  215 CALL EFST3(EST2,SX2,SY2,SZ2,SXY2,SXZ2,SYZ2,STRSS2)
C
      DO 218 I=1,6
  218 DELSIG(I)=STRSS2(I) - STRSS1(I)
C
      CALL EFST3(EST,DX,DY,DZ,DXY,DXZ,DYZ,DELSIG)
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.10) GO TO 220
C
      SX2=SX2 - ALFA1(1)
      SY2=SY2 - ALFA1(2)
      SZ2=SZ2 - ALFA1(3)
      SXY2=SXY2 - ALFA1(4)
      SXZ2=SXZ2 - ALFA1(5)
      SYZ2=SYZ2 - ALFA1(6)
C
C     CALCULATE YIELD STRESS AT END OF SUBDIVISION *
C
  220 YM2=PROP2(1)
      ET2=PROP2(4)
      YS2=PROP2(3)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
      DYLD=YS2 - YS1
      IF(MODEL.EQ.10) DYLD=DYLD + (EET2 - EET1)*EPSTR1
      YLD2=YLD1 + DYLD
C
  225 RA=DX*DX + DY*DY + DZ*DZ + 2.0*(DXY*DXY + DXZ*DXZ + DYZ*DYZ)
      FTA=SX2*SX2 + SY2*SY2 + SZ2*SZ2 + 2.0*(SXY2*SXY2 + SXZ2*SXZ2 +
     1    SYZ2*SYZ2)
C
C     CHECK FOR NO CHANGE IN DEVIATORIC STRESS-TEMPERATURE STATE *
C
      IF(RA.EQ.0.0.AND.TMP1.EQ.TMP2) GO TO 228
C
      FTB=XCON1*YLD2*YLD2
      IF(FTA.GT.FTB) GO TO 250
C
C        16. STRESS STATE IS WITHIN THE YIELD SURFACE---
C            THERMO-ELASTIC/CREEP BEHAVIOR
C
      IPELD=1
  228 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 230
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 245
      GO TO 235
C
C    NALG .EQ. 2 *
C
  230 IF(TAU.GE.TCHK .OR. KCRP.EQ.0) GO TO 245
      IF(DECSTR.LE.TOL5) GO TO 232
C
      DELT=DELT*TOLPC*(1.0 + (ECSTR1/DECSTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 233
C
  232 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  233 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 235
C
      WRITE(6,3007)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  235 ISUB=ISUB + 1
      INDEX=1
      YS1=YS2
      EET1=EET2
      YLD1=YLD2
      TMP1=TMP2
C
      DO 240 J=1,6
      EPS1(J)=EPS2(J)
      STRSS1(J)=STRSS2(J)
  240 EPSC1(J)=EPSC2(J)
C
      GO TO 60
C
C     AT END OF TIME STEP, CALCULATE YIELD STRESS USING DEFINITION
C     BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE PLASTIC STRAIN **
C
  245 YLDC=YS2
      IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
C
      GO TO 440
C
C        17. STRESS-TEMPERATURE STATE IS OUTSIDE THE YIELD
C            SURFACE---THERMO-ELASTIC-PLASTIC/CREEP BEHAVIOR
C
C            THERMO-ELASTIC-PLASTIC/CREEP STRESS CALCULATIONS
C            FOLLOW
C
C     CALCULATE THE FRACTION OF THE STRAIN SUBDIVISION OVER WHICH
C     THERE IS NO PLASTIC STRAINING **
C
  250 CALL EFST3(EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,STRSS1)
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.10) GO TO 255
C
      SX1=SX1 - ALFA1(1)
      SY1=SY1 - ALFA1(2)
      SZ1=SZ1 - ALFA1(3)
      SXY1=SXY1 - ALFA1(4)
      SXZ1=SXZ1 - ALFA1(5)
      SYZ1=SYZ1 - ALFA1(6)
C
  255 RB=SX1*DX + SY1*DY + SZ1*DZ + 2.0*(SXY1*DXY + SXZ1*DXZ + SYZ1*DYZ)
      RD=SX1*SX1 + SY1*SY1 + SZ1*SZ1 + 2.0*(SXY1*SXY1 + SXZ1*SXZ1 +
     1   SYZ1*SYZ1)
      RE=RB - (XCON1*YLD1*DYLD)
      RF=RA - (XCON1*DYLD*DYLD)
      RG=RD - (XCON1*YLD1*YLD1)
C
      IF(IPELD.EQ.2.OR.RG.GE.0.0) GO TO 270
C
C     STRESS-TEMPERATURE STATE IS WITHIN THE YIELD SURFACE AT
C     START OF SUBDIVISION *
C
  260 IF(DABS(RF).GT.TOL5) GO TO 265
      RATIO=-RG/(2.0*RE)
      GO TO 275
C
  265 RATIO=(-RE + DSQRT(RE*RE - RF*RG))/RF
      GO TO 275
C
C     STRESS-TEMPERATURE STATE IS ON THE YIELD SURFACE AT START
C     OF SUBDIVISION *
C
  270 RATIO=0.0
      IF(RF.GT.TOL5.AND.RE.LT.0.0) RATIO=-2.0*RE/RF
C
C     CHECK CALCULATED VALUE OF RATIO **
C
  275 IF(RATIO.GE.(-TOL6) .AND. RATIO.LE.(1.0 + TOL6)) GO TO 280
C
      WRITE(6,3012)
      WRITE(6,3013) NEL,IPT,ISUB,TAU,IPELD,RA,RB,RD,RE,RF,RG,RATIO
      STOP
C
  280 IF(RATIO.GT.1.0) RATIO=1.0
      IF(RATIO.LT.0.0) RATIO=0.0
      IPELD=2
C
C        18. UPDATE ALL VARIABLES TO START OF YIELDING
C
      TAU=TAU + RATIO*DELT
      TMP1=TMPOLD + DELTMP*TAU/DTT
      YLD1=YLD1 + RATIO*DYLD
      IF(RATIO.GT.TOL5) ISUB=ISUB + 1
      IF(ISUB.GT.ISUBM) ISUBM=ISUBM + 1
C
C     CALCULATE STRESSES, TOTAL STRAINS, AND CREEP STRAINS AT
C     START OF YIELDING **
C
      DO 285 J=1,6
      EPS1(J)=EPS1(J) + RATIO*DEPS(J)
      EPSC1(J)=EPSC1(J) + RATIO*DPSC(J)
      EPSC2(J)=EPSC1(J)
      STRSS1(J)=STRSS1(J) + RATIO*DELSIG(J)
  285 STRSS2(J)=STRSS1(J)
C
C     CALCULATE MATERIAL PROPERTIES AT START OF YIELDING **
C
  288 CALL EMAT3(TMP1,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
C
C     CALCULATE THERMAL STRAINS AT START OF YIELDING **
C
      ALPHA1=PROP1(5)
      EPST1(1)=ALPHA1*(TMP1 - TREF)
C
C        19. CALCULATE SIZE OF FIRST SUBDIVISION AFTER YIELDING
C            (STRESS LOOP NO. 2)
C
  290 XNWDT=DTT - TAU
      DELT=XNWDT/DBLE(FLOAT(ISUBM - ISUB + 1))
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
C
C        20. CALCULATE TEMPERATURE AT END OF SUBDIVISION
C            AND WEIGHTED TEMPERATURE
C
  292 TMP2=TMPOLD + DELTMP*(TAU + DELT)/DTT
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
C        21. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C            CALCULATE WEIGHTED MATERIAL PROPERTIES
C
      CALL EMAT3(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
      DO 295 J=1,5
  295 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
      YMM=PROPM(1)
      ETM=PROPM(4)
C
      EETM=YMM*ETM/(YMM - ETM)
      CEM=XCON1*EETM
C
C        22. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
C            AND THERMAL STRAIN CHANGE FOR THE SUBDIVISION
C
      ALPHA2=PROP2(5)
C
      EPST2(1)=ALPHA2*(TMP2 - TREF)
      EPST2(2)=EPST2(1)
      EPST2(3)=EPST2(1)
C
      DPST=EPST2(1) - EPST1(1)
C
C        23. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
C            AND TOTAL STRAIN CHANGE FOR THE SUBDIVISION
C
  300 XFAC=(TAU + DELT)/DTT
      DO 305 J=1,6
      EPS2(J)=EPS(J) + XFAC*DELEPS(J)
  305 DEPS(J)=EPS2(J) - EPS1(J)
C
C        24. CALCULATE WEIGHTED STRESS
C
  310 DO 315 J=1,6
  315 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
C
      CALL EFST3(ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,STRSSM)
C
C        25. CALCULATE WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
      EPSTRM=XPARM1*EPSTR1 + XPARM2*EPSTR2
C
C        26. CALCULATE WEIGHTED YIELD SURFACE TRANSLATION
C
      IF(MODEL.EQ.10) GO TO 320
C
      DO 318 J=1,6
  318 ALFAM(J)=XPARM1*ALFA1(J) + XPARM2*ALFA2(J)
      GO TO 324
C
C        27. CALCULATE WEIGHTED YIELD STRESS
C
C     ISOTROPIC HARDENING **
C
  320 YLDM=ESTM
      GO TO 328
C
C     KINEMATIC HARDENING **
C
  324 DO 325 J=1,6
  325 DSTSS(J)=STRSSM(J) - ALFAM(J)
C
      CALL EFST3(YLDM,SXT,SYT,SZT,SXYT,SXZT,SYZT,DSTSS)
C
C        28. PRELIMINARY CREEP CALCULATIONS
C
  328 IF(KCRP.EQ.0) GO TO 335
C
      DO 330 J=1,6
  330 DPSC(J)=0.0
      CRSRM=0.0
C
      DO 332 J=1,6
  332 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
C
      CALL CREEP3(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
     1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,
     2            FF,RR,GG,INDEX,ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        29. CALCULATE PLASTIC STRAINS AT END OF SUBDIVISION
C
  335 CALL EPMAT3(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
     1            PROP1,PROP2,PROPM,YLDM,1,A2,B2,C1,C2,DPSP,SXM,SYM,SZM,
     2            SXYM,SXZM,SYZM,INDEX,EETM)
C
  342 DO 344 J=1,6
  344 EPSP2(J)=EPSP1(J) + DPSP(J)
C
      IF(XLAMDA.LE.0.0) GO TO 345
C
C        30. CALCULATE ACCUMULATED EFFECTIVE PLASTIC STRAIN AT END
C            OF SUBDIVISION
C
      DEPSTR=DSQRT(XCON1*(DPSP(1)*DPSP(1) + DPSP(2)*DPSP(2) + DPSP(3)*
     1            DPSP(3)) + XCON2*(DPSP(4)*DPSP(4) + DPSP(5)*DPSP(5) +
     2            DPSP(6)*DPSP(6)))
      EPSTR2=EPSTR1 + DEPSTR
C
C        31. CALCULATE YIELD SURFACE TRANSLATION AT END
C            OF SUBDIVISION
C
      IF(MODEL.EQ.10) GO TO 345
C
      ALFA2(1)=ALFA1(1) + CEM*DPSP(1)
      ALFA2(2)=ALFA1(2) + CEM*DPSP(2)
      ALFA2(3)=ALFA1(3) + CEM*DPSP(3)
      ALFA2(4)=ALFA1(4) + 0.5*CEM*DPSP(4)
      ALFA2(5)=ALFA1(5) + 0.5*CEM*DPSP(5)
      ALFA2(6)=ALFA1(6) + 0.5*CEM*DPSP(6)
C
C        32. CALCULATE THE STRESSES AND CREEP STRAINS AT
C            END OF SUBDIVISION
C
  345 CALL SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,DELT,
     2            B2,C2,D2)
C
C        33. CHECK FOR CONVERGENCE OF ITERATION
C
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK.EQ.0)
C     OR WHEN XPARM2 .EQ. 0.0 **
C
  350 IF(XPARM2.EQ.0.0) GO TO 400
      IF(ITCHK.EQ.1) GO TO 358
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 310
      GO TO 400
C
C     CALCULATE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
C     STRESS VECTOR **
C
  358 IF(INDEX - 4) 360,366,362
C
  360 INDEX=INDEX + 1
      GO TO 310
C
  362 DNORM2=0.0
      DO 365 J=1,6
  365 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
C
C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
C
  366 SNORM=0.0
      DO 368 J=1,6
  368 SNORM=SNORM + STRSS2(J)*STRSS2(J)
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 375
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      DO 370 J=1,6
  370 STRSSD(J)=STRSS2(J)
      GO TO 310
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  375 IF(DNORM2.LE.DNORM1) GO TO 390
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 400
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 380
C
  378 WRITE(6,3008)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
C
  380 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      DO 385 I=1,6
      STRSS2(I)=STRSS1(I)
      EPSP2(I)=EPSP1(I)
      ALFA2(I)=ALFA1(I)
  385 EPSC2(I)=EPSC1(I)
C
      GO TO 292
C
C     FINAL CHECK FOR CONVERGENCE *
C
  390 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 400
C
C     NO CONVERGENCE
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 395
C
      WRITE(6,3003)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  395 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
C
      DO 398 J=1,6
  398 STRSSD(J)=STRSS2(J)
      GO TO 310
C
C        34. CHECK SIZE OF INELASTIC STRAIN INCREMENT
C
C     CHECK IS BYPASSED WHEN THE EFFECTIVE INELASTIC STRAIN AT THE
C     START OF THE SUBDIVISION AND/OR THE EFFECTIVE INELASTIC STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0 **
C
  400 DECSTR=CRSRM*DELT
      DESTR=DECSTR + DEPSTR
      DENOM=ECSTR1 + EPSTR1
      IF(DESTR.LE.TOL5.OR.DENOM.LE.TOL5) GO TO 410
C
      CHECK=DESTR/(DENOM*TOLPC)
      IF(CHECK.LE.1.1) GO TO 410
C
C     INELASTIC STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 405
C
      WRITE(6,3009)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
C
  405 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      DO 408 I=1,6
      STRSS2(I)=STRSS1(I)
      EPSP2(I)=EPSP1(I)
      ALFA2(I)=ALFA1(I)
  408 EPSC2(I)=EPSC1(I)
C
      GO TO 292
C
C        35. CALCULATE YIELD STRESS AT END OF SUBDIVISION
C
  410 YM2=PROP2(1)
      ET2=PROP2(4)
      YS2=PROP2(3)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
C     USING DEFINITION BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE
C     PLASTIC STRAIN **
C
C     KINEMATIC HARDENING *
C
      YLDC=YS2
C
C     ISOTROPIC HARDENING *
C
      IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
C
C     USING STRESS STATE **
C
C     ISOTROPIC HARDENING *
C
      IF(MODEL.EQ.11) GO TO 412
      CALL EFST3(YLD2,SX2,SY2,SZ2,SXY2,SXZ2,SYZ2,STRSS2)
      GO TO 414
C
C     KINEMATIC HARDENING *
C
  412 DO 413 J=1,6
  413 DSTSS(J)=STRSS2(J) - ALFA2(J)
C
      CALL EFST3(YLD2,SXT,SYT,SZT,SXYT,SXZT,SYZT,DSTSS)
C
C        36. CORRECT STRESS STATE TO YIELD SURFACE
C
C     CHECK YIELD SURFACE ERROR **
C
  414 CHECK=DABS(YLD2 - YLDC)/DMIN1(YLD2,YLDC)
      IF(CHECK.LE.TOL7) GO TO 415
C
      WRITE(6,3014)
      WRITE(6,3015) NEL,IPT,ISUB,TAU,YLD2,YLDC
      STOP
C
C     *** THIS VERSION OF ADINA DOES NOT HAVE A CORRECTION FOR
C         ISOTHERMAL PERFECT PLASTICITY OR ISOTHERMAL KINEMATIC
C         HARDENING ***
C
C
C        37. UPDATE VARIABLES FOR NEXT SUBDIVISION
C
  415 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 416
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 440
      GO TO 425
C
C     NALG .EQ. 2 *
C
  416 IF(TAU.GE.TCHK) GO TO 440
      IF(DESTR.LE.TOL5) GO TO 420
C
      DELT=DELT*TOLPC*(1.0 + (DENOM/DESTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 422
C
  420 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  422 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 425
C
      WRITE(6,3010)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  425 ISUB=ISUB + 1
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      TMP1=TMP2
      EPSTR1=EPSTR2
      EPST1(1)=EPST2(1)
C
      A1=A2
      B1=B2
      C1=C2
      D1=D2
      E1=E2
      F1=F2
C
      DO 430 J=1,6
      EPS1(J)=EPS2(J)
      STRSS1(J)=STRSS2(J)
      EPSC1(J)=EPSC2(J)
      ALFA1(J)=ALFA2(J)
  430 EPSP1(J)=EPSP2(J)
C
      DO 435 J=1,5
  435 PROP1(J)=PROP2(J)
C
      GO TO 292
C
C        38. PERMANENT UPDATING OF VARIABLES
C
  440 IF(IUPDT.NE.0) GO TO 455
C
      DO 445 J=1,6
      SIG(J)=STRSS2(J)
      ALFA(J)=ALFA2(J)
      EPSC(J)=EPSC2(J)
      EPSP(J)=EPSP2(J)
  445 EPS(J)=STRAIN(J)
C
      YLD=YLD2
      EPSTR=EPSTR2
      TMPOLD=TMP2
      IPEL=IPELD
      NORG=NORGD
C
      DO 450 I=1,6
      DO 450 J=1,2
  450 ORIG(I,J)=ORIGD(I,J)
C
C        39. CALCULATE LATEST CONSTITUTIVE LAW
C
C     CHECK FOR EQUILIBRIUM ITERATION **
C
  455 IF(ICOUNT.EQ.3) RETURN
C
C     CHECK FOR PRINTING OF STRESSES **
C
      IF(KPRI.EQ.0) GO TO 600
C
C     UPDATE SOLUTION VARIABLES **
C
      DO 458 J=1,6
      EPSC1(J)=EPSC2(J)
      EPSP1(J)=EPSP2(J)
      EPST1(J)=EPST2(J)
      STRSS1(J)=STRSS2(J)
  458 ALFA1(J)=ALFA2(J)
C
      YLD1=YLD2
      EPSTR1=EPSTR2
C
C     CALCULATE MATERIAL PROPERTIES AT END OF NEXT TIME STEP **
C
      A1=A2
      B1=B2
      C1=C2
      D1=D2
      E1=E2
      F1=F2
C
      DO 460 I=1,5
  460 PROP1(I)=PROP2(I)
C
      CALL EMAT3(TEMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
C
C     CALCULATE THERMAL STRAINS AT END OF NEXT TIME STEP **
C
      ALPHA2=PROP2(5)
      EPST=ALPHA2*(TEMP2 - TREF)
      DPST=EPST - EPST1(1)
C
      DO 465 J=1,3
      EPST2(J)=EPST
  465 DEPST(J)=DPST
C
C     ESTIMATE CREEP STRAINS AT END OF NEXT TIME STEP **
C
      INDEX=1
      CALL EFST3(EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,STRSS1)
C
      IF(KCRP.EQ.0) GO TO 480
C
      DO 470 J=1,6
  470 DPSC(J)=0.0
C
      IF(EST1.LE.TOL5) GO TO 480
      TMPM=XPARM1*TEMP1 + XPARM2*TEMP2
C
      CALL CREEP3(DT,DPSC,TMPM,EPSC1,ORIGD,NORGD,STRSS1,GAMA,CRSR1,
     1            PTIME,EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,FF,RR,GG,INDEX,
     2            ECSTR1)
C
      DO 475 I=1,6
  475 EPSC2(I)=EPSC1(I) + DPSC(I)
C
C     CHECK ELASTIC-PLASTIC INDICATOR **
C
  480 IF(IPELD.EQ.2) GO TO 490
C
C     THERMO-ELASTIC AND CREEP BEHAVIOR **
C
      DO 482 J=1,6
  482 STRESS(J)=0.0
C
      DO 485 I=1,6
      DO 485 J=1,6
  485 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J) -
     1          EPST2(J))
C
      RETURN
C
C     THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR **
C
C
C     CALCULATE WEIGHTED MATERIAL PROPERTIES *
C
  490 DO 494 J=1,5
  494 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
C     ESTIMATE PLASTIC STRAINS AT END OF NEXT TIME STEP *
C
  500 YMM=PROPM(1)
      ETM=PROPM(4)
      EETM=YMM*ETM/(YMM - ETM)
C
      CALL EPMAT3(STRSS1,ALFA1,EPSTR1,DELEPS,DPSC,DPST,CEP,XLAMDA,
     1            PROP1,PROP2,PROPM,YLD1,2,A2,B2,C1,C2,DPSP,SX1,SY1,SZ1,
     2            SXY1,SXZ1,SYZ1,INDEX,EETM)
C
      DO 505 J=1,6
      STRESS(J)=0.0
  505 EPSP2(J)=EPSP1(J) + DPSP(J)
C
      IF(IEQREF.EQ.1 .OR. XLAMDA.LT.0.0) GO TO 520
C
C     ITERATION WITH ELASTIC-PLASTIC STIFFNESS MATRIX *
C
      DO 510 I=1,6
      DO 510 J=1,6
  510 STRESS(I)=STRESS(I) - CEP(I,J)*(DPSC(J) + DEPST(J)) + C(I,J)*
     1          (STRAIN(J) - EPSP1(J) - EPSC1(J) - EPST1(J) - DPSP(J))
C
      DO 515 I=1,6
      DO 515 J=1,6
  515 C(I,J)=CEP(I,J)
C
      RETURN
C
C     ITERATION WITH ELASTIC STIFFNESS MATRIX WHEN GLOBAL DIVERGENCE
C     PROCEDURE IS ACTIVATED OR UNLOADING IS DETECTED *
C
  520 DO 535 I=1,6
      DO 535 J=1,6
  535 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J)
     1          - EPST2(J))
C
      RETURN
C
C        40. PRINTING OF STRESSES
C
C     CALCULATE EFFECTIVE STRESS **
C
  600 FT=YLD2
      IF(IPELD.EQ.1) FT=DSQRT(1.5*FTA)
C
C     IN TOTAL LAGRANGIAN FORMULATION, CALCULATE CAUCHY STRESSES **
C
  605 IF(INDNL.EQ.2) CALL CAUCH3
C
  610 IF(IPRI.NE.0) RETURN
      IF (IPS.LT.0) GO TO 700
C
C     STRESS PRINTOUT ONLY **
C
      IF(IPT.GT.1) GO TO 620
C
C     PRINT HEADING *
C
      WRITE(6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE(6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES *
C
  620 WRITE(6,2200) IPT,STATE(IPELD),(STRSS2(J),J=1,6)
      WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
C
      RETURN
C
C     STRESS AND STRAIN PRINTOUT **
C
  700 IF(IPT.GT.1) GO TO 720
C
C     PRINT HEADING *
C
      WRITE(6,2000)
C
C     PRINT ELEMENT NUMBER *
C
      WRITE(6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESSES AND STRAINS *
C
  720 WRITE(6,2200) IPT,STATE(IPELD),(STRSS2(J),J=1,6)
      WRITE(6,2300) (STRAIN(J),J=1,6)
      WRITE(6,2400) (EPSP2(J),J=1,6)
      WRITE(6,2500) (EPSC2(J),J=1,6)
      WRITE(6,2600) (EPST2(J),J=1,6)
      WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
C
      RETURN
C
 2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,
     1        13X,2HYY,13X,2HZZ,13X,2HXY,13X,2HXZ,13X,2HYZ,/,1X,
     2        7HNUM/IPT,3X,5HSTATE,4X,10HCOMPONENTS)
 2005 FORMAT (/,1X,I3)
 2200 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,6(E14.6,1X))
 2300 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
 2400 FORMAT (25X,7HPLASTIC,3X,6(E14.6,1X))
 2500 FORMAT (27X,5HCREEP,3X,6(E14.6,1X))
 2600 FORMAT (25X,7HTHERMAL,3X,6(E14.6,1X))
 2700 FORMAT (20X,14HTEMPERATURE = ,E14.6,1X,
     1        29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,1X,
     2        25HNUMBER OF SUBDIVISIONS = ,I5,/,20X,
     3        12HEFF STRESS = ,E14.6,1X,
     4        13HYLD STRESS = ,E14.6,1X,
     5        41HYLD STRESS(TMP.,ACC. EFF. PLAS. STRN.) = ,E14.6,/)
 3001 FORMAT(//,68H    ERROR   STRESS LOOP NO. 1 FAILED TO CONVERGE   (S
     1UBROUTINE EPC3))
 3002 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       13HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       40HAPPROXIMATE REQUIRED SUBDIVISION SIZE = ,E14.6)
 3003 FORMAT(//,68H    ERROR   STRESS LOOP NO. 2 FAILED TO CONVERGE   (S
     1UBROUTINE EPC3))
 3004 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBROUTINE EPC3))
 3006 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBRO
     2UTINE EPC3))
 3007 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 1   (SUBROUTINE EPC3))
 3008 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBROUTINE EPC3))
 3009 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBRO
     2UTINE EPC3))
 3010 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 2   (SUBROUTINE EPC3))
 3011 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       24HLAST SUBDIVISION SIZE = ,E14.6)
 3012 FORMAT(//,70H    ERROR   INCORRECT VALUE CALCULATED FOR *RATIO*
     1(SUBROUTINE EPC3))
 3013 FORMAT(//,5X,10HELEMENT = ,I5,1X,20HINTEGRATION POINT = ,I5,1X,
     1       14HSUBDIVISION = ,I5,1X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,1X,
     3        7HIPEL = ,I2,/,5X,
     4        5HRA = ,E14.6,1X,5HRB = ,E14.6,1X,5HRD = ,E14.6,
     5        5HRE = ,E14.6,1X,5HRF = ,E14.6,1X,5HRG = ,E14.6,/,5X,
     6        8HRATIO = ,E14.6,//)
 3014 FORMAT(//,101H    ERROR   DIFFERENCE BETWEEN THE TWO MEASURES OF Y
     1IELD STRESS EXCEEDS TOLERANCE   (SUBROUTINE EPC3))
 3015 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,2X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,/,5X,
     3       35HYIELD STRESS (FROM STRESS STATE) = ,E14.6,2X,
     4       54HYIELD STRESS (FROM TEMPERATURE AND ACCUM. EFF. PLASTIC,
     5       10HSTRAIN) = ,E14.6,//)
C
      END
C *CDC* *DECK SIGMA3
C *UNI* )FOR,IS  N.SIGMA3, R.SIGMA3
C
      SUBROUTINE SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,
     1                  PTIME,STRNR,F,R,G,EST,SX,SY,SZ,SXY,SXZ,SYZ,
     2                  DELT,XB2,XC2,XD2)
C
C
C
C     THIS SUBROUTINE USES A NEWTON-RAPHSON METHOD TO CALCULATE
C     STRESSES AND CREEP STRAINS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM3/ 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
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION STRSS2(1),EPS2(1),EPSP2(1),EPST2(1),EPSC1(1),EPSC2(1),
     1          DPSC(1),TSTRSS(6),RH(6),TC(6,6),TTC(6,6)
C
C
C
C
      DO 10 J=1,6
      TSTRSS(J)=STRSS2(J)
   10 RH(J)=0.0
C
      DO 20 I=1,6
      DO 20 J=1,6
   20 TC(I,J)=0.0
C
C        1. FORM FIRST PART OF R.H.S. VECTOR
C
      DO 25 I=1,6
      DO 25 J=1,6
   25 RH(I)=RH(I) + C(I,J)*(EPS2(J) - EPSP2(J) - EPSC1(J) - DPSC(J)
     1      - EPST2(J))
C
      IF(XPARM2.GT.0.0.AND.KCRP.GT.0.AND.EST.GT.TOL5) GO TO 35
C
      DO 30 I=1,6
      EPSC2(I)=EPSC1(I) + DPSC(I)
   30 STRSS2(I)=RH(I)
C
      RETURN
C
C        2. FORM THE PART OF THE ITERATION MATRIX USED TO CALCULATE
C           THE R.H.S. VECTOR AND THE CREEP STRAIN INCREMENT
C
   35 A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 40
C
C     CREEP LAW NO. 1 **
C
      GG=1.5*(A1 - A2)*GAMA/(A2*EST*EST)
      GO TO 50
C
C     CREEP LAW NO. 2 **
C
   40 C2=A4 - 1.0
      C1=1.5*A2*A4*(A3**(-A4))
      C3=1.5*A1
      C4=1.5*A6
C
      D1=DEXP(-R*PTIME)*F
      D2=EST**C2
C
      DTPSP=(D1*(C3 - PTIME*C1*D2) - C3*F - PTIME*C4*G)/STRNR
C
      GG=(1.5*D1*(C1*D2 - R*(PTIME*C1*D2 + R*DTPSP - C3)) + 1.5*C4*G -
     1   1.5*GAMA)/(EST*EST)
C
   50 COEF=2.0*XC2*XPARM2*DELT
C
      TC(1,1)=COEF*(GG*SX*SX + XCON1*GAMA)
      TC(1,2)=COEF*(GG*SX*SY - XCON2*GAMA)
      TC(1,3)=COEF*(GG*SX*SZ - XCON2*GAMA)
      TC(1,4)=COEF*(2.0*GG*SX*SXY)
      TC(1,5)=COEF*(2.0*GG*SX*SXZ)
      TC(1,6)=COEF*(2.0*GG*SX*SYZ)
C
      TC(2,1)=TC(1,2)
      TC(2,2)=COEF*(GG*SY*SY + XCON1*GAMA)
      TC(2,3)=COEF*(GG*SY*SZ - XCON2*GAMA)
      TC(2,4)=COEF*(2.0*GG*SY*SXY)
      TC(2,5)=COEF*(2.0*GG*SY*SXZ)
      TC(2,6)=COEF*(2.0*GG*SY*SYZ)
C
      TC(3,1)=TC(1,3)
      TC(3,2)=TC(2,3)
      TC(3,3)=COEF*(GG*SZ*SZ + XCON1*GAMA)
      TC(3,4)=COEF*(2.0*GG*SZ*SXY)
      TC(3,5)=COEF*(2.0*GG*SZ*SXZ)
      TC(3,6)=COEF*(2.0*GG*SZ*SYZ)
C
      TC(4,1)=TC(1,4)
      TC(4,2)=TC(2,4)
      TC(4,3)=TC(3,4)
      TC(4,4)=COEF*(2.0*GG*SXY*SXY + GAMA)
      TC(4,5)=COEF*(2.0*GG*SXY*SXZ)
      TC(4,6)=COEF*(2.0*GG*SXY*SYZ)
C
      TC(5,1)=TC(1,5)
      TC(5,2)=TC(2,5)
      TC(5,3)=TC(3,5)
      TC(5,4)=TC(4,5)
      TC(5,5)=COEF*(2.0*GG*SXZ*SXZ + GAMA)
      TC(5,6)=COEF*(2.0*GG*SXZ*SYZ)
C
      TC(6,1)=TC(1,6)
      TC(6,2)=TC(2,6)
      TC(6,3)=TC(3,6)
      TC(6,4)=TC(4,6)
      TC(6,5)=TC(5,6)
      TC(6,6)=COEF*(2.0*GG*SYZ*SYZ + GAMA)
C
      DO 55 I=1,6
      DO 55 J=1,6
   55 TTC(I,J)=TC(I,J)/(2.0*XC2)
C
C        3. FORM ITERATION MATRIX AND SECOND PART OF R.H.S. VECTOR
C
   80 DO 95 I=1,6
      DO 95 J=1,6
   95 RH(I)=RH(I) + TC(I,J)*STRSS2(J)
C
      DO 110 J=1,6
  110 TC(J,J)=TC(J,J) + 1.0
C
C        4. CALCULATE STRESSES AT END OF SUBDIVISION
C
      CALL EQSOL3(TC,RH,1,6)
C
      DO 130 J=1,6
  130 STRSS2(J)=RH(J)
C
C        5. CALCULATE CREEP STRAINS AT END OF SUBDIVISION
C
      DO 160 I=1,6
      DO 150 J=1,6
  150 DPSC(I)=DPSC(I) + TTC(I,J)*(STRSS2(J) - TSTRSS(J))
  160 EPSC2(I)=EPSC1(I) + DPSC(I)
C
      RETURN
C
      END
C *CDC* *DECK EQSOL3
C *UNI* )FOR,IS  N.EQSOL3, R.EQSOL3
C
      SUBROUTINE EQSOL3(A,R,KEY,N)
C
C
C
C     THIS SUBROUTINE SOLVES A SYSTEM OF LINEAR ALGEBRAIC
C     EQUATIONS USING GAUSSIAN ELIMINATION WITH COMPLETE PIVOTING
C
C     THE ROW MULTIPLIERS ARE STORED IN THE LOWER TRIANGULAR PART OF
C     THE REDUCED COEFFICIENT MATRIX
C
C     THE SOLUTION VARIABLES ARE RETURNED IN THE R.H.S. VECTOR
C
C     THE FOLLOWING VARIABLES ARE USED
C        A = COEFFICIENT MATRIX
C        R = R.H.S. VECTOR
C        N = NUMBER OF EQUATIONS
C        KEY = CONTROL VARIABLE
C            = 1 COMPLETE SOLUTION
C            = 2 R.H.S. REDUCTION AND BACK-SUBSTITUTION
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(6,6),R(6),ICOL(6),TR(6),IROW(6)
C
C
C
      EPS=1.0D-50
      NN=N-1
      IF(KEY.EQ.2) GO TO 110
C
      DO 10 I=1,N
      IROW(I)=I
   10 ICOL(I)=I
C
      DO 100 J=1,NN
C
C        1. SEARCH FOR LARGEST PIVOT
C
      PIVI=0.0
      DO 20 I=J,N
      DO 20 K=J,N
      IF(DABS(A(I,K)).LE.DABS(PIVI)) GO TO 20
      IMAX=I
      KMAX=K
      PIVI=A(I,K)
   20 CONTINUE
C
      IF(DABS(PIVI).GT.EPS) GO TO 25
      WRITE(6,7000)
      WRITE(6,7010) J
      STOP
C
C        2. INTERCHANGE COLUMNS
C
   25 IF(KMAX.EQ.J) GO TO 40
C
      ISAVE=ICOL(KMAX)
      ICOL(KMAX)=ICOL(J)
      ICOL(J)=ISAVE
C
      DO 30 JJ=1,N
      SAVE=A(JJ,KMAX)
      A(JJ,KMAX)=A(JJ,J)
   30 A(JJ,J)=SAVE
C
C        3. INTERCHANGE ROWS
C
   40 IF(IMAX.EQ.J) GO TO 85
C
      ISAVE=IROW(IMAX)
      IROW(IMAX)=IROW(J)
      IROW(J)=ISAVE
C
      DO 50 K=1,N
      SAVE=A(J,K)
      A(J,K)=A(IMAX,K)
   50 A(IMAX,K)=SAVE
C
      SAVE=R(J)
      R(J)=R(IMAX)
      R(IMAX)=SAVE
C
C        4. REDUCE COEFFICIENT MATRIX AND STORE MULTIPLIERS
C
   85 I2=J + 1
      DO 90 K2=I2,N
      XMULT=A(K2,J)/PIVI
      A(K2,J)=XMULT
      DO 90 J2=I2,N
   90 A(K2,J2)=A(K2,J2) - XMULT*A(J,J2)
C
  100 CONTINUE
      GO TO 150
C
C        5. REDUCE R.H.S. VECTOR
C
C     FOR KEY = 2, REORDER R.H.S. VECTOR **
C
  110 DO 120 J=1,N
      K=IROW(J)
  120 TR(J)=R(K)
C
      DO 130 J=1,N
  130 R(J)=TR(J)
C
  150 DO 200 J=1,NN
      I2=J + 1
      DO 200 K2=I2,N
      XMULT=A(K2,J)
  200 R(K2)=R(K2) - XMULT*R(J)
C
C        6. BACK-SUBSTITUTION
C
      DO 320 I=1,N
      TSUM=0.0
      II=N + 1 - I
      IF(II.EQ.N) GO TO 315
      JJ=II + 1
C
      DO 310 K=JJ,N
  310 TSUM=TSUM + A(II,K)*R(K)
C
  315 R(II)=(R(II) - TSUM)/A(II,II)
  320 CONTINUE
C
C        7. REORDER VARIABLES TO ACCOUNT FOR PIVOTING
C
      DO 330 J=1,N
      K=ICOL(J)
  330 TR(K)=R(J)
C
      DO 340 J=1,N
  340 R(J)=TR(J)
C
      RETURN
C
 7000 FORMAT(///,64H   ERROR   UNABLE TO OBTAIN NON-ZERO PIVOT   (SUBROU
     1TINE EQSOL3))
 7010 FORMAT(/,10X,15HPIVOT NUMBER = ,I5)
C
      END
C *CDC* *DECK EFST3
C *UNI* )FOR,IS  N.EFST3, R.EFST3
C
      SUBROUTINE EFST3(EST,SX,SY,SZ,SXY,SXZ,SYZ,STRESS)
C
C
C
C     THIS SUBROUTINE CALCULATES THE DEVIATORIC STRESS
C     COMPONENTS AND THE EFFECTIVE STRESS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM3/ 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
C
      DIMENSION STRESS(6)
C
C
C
      SM=(STRESS(1) + STRESS(2) + STRESS(3))*XCON2
C
      SX=STRESS(1)-SM
      SY=STRESS(2)-SM
      SZ=STRESS(3)-SM
      SXY=STRESS(4)
      SXZ=STRESS(5)
      SYZ=STRESS(6)
C
      EST=DSQRT(1.5*(SX*SX + SY*SY + SZ*SZ + 2.0*(SXY*SXY + SXZ*SXZ +
     1         SYZ*SYZ)))
C
      RETURN
C
      END
C *CDC* *DECK EPMAT3
C *UNI* )FOR,IS  N.EPMAT3, R.EPMAT3
C
      SUBROUTINE EPMAT3(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
     1                  PROP1,PROP2,PROPM,YLDM,KEY,A2,B2,C1,C2,DPSP,
     2                  SXM,SYM,SZM,SXYM,SXZM,SYZM,INDEX,EETM)
C
C
C     THIS SUBROUTINE CALCULATES PLASTIC STRAIN INCREMENTS AND THE
C     ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C
C
C
C     KEY = 1  CALCULATE PLASTIC STRAIN INCREMENTS
C              (STRESS CALCULATIONS)
C         = 2  CALCULATE PLASTIC STRAIN INCREMENTS AND
C              ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C              (FORMING STIFFNESS MATRIX)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /SOLPM3/ 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
      COMMON /TPLAS3/ EETD,PRM,CM,CD,YSD
C
      DIMENSION STRSSM(1),ALFAM(1),DEPS(1),DPSC(1),PROP1(1),
     1          PROP2(1),PROPM(1),CEP(6,6),DPSP(6)
C
      EQUIVALENCE (NPAR(15),MODEL)
C
C
C
C
C        1. INITIALIZE VARIABLES
C
      SXT=SXM
      SYT=SYM
      SZT=SZM
      SXYT=SXYM
      SXZT=SXZM
      SYZT=SYZM
C
      IF(INDEX.GT.1) GO TO 40
C
      YMM=PROPM(1)
      PRM=PROPM(2)
      ETM=PROPM(4)
C
      YMD=PROP2(1) - PROP1(1)
      PRD=PROP2(2) - PROP1(2)
      ETD=PROP2(4) - PROP1(4)
      YSD=PROP2(3) - PROP1(3)
C
      CD=C2 - C1
      CM=0.5*YMM/(1.0 + PRM)
      EETD=((YMM*YMM*ETD) - (ETM*ETM*YMD))/((YMM - ETM)*(YMM - ETM))
C
C        2. CALCULATE PLASTIC STRAIN INCREMENT
C
C     KINEMATIC HARDENING **
C
   40 IF(MODEL.EQ.10) GO TO 50
C
      SXM=SXM - ALFAM(1)
      SYM=SYM - ALFAM(2)
      SZM=SZM - ALFAM(3)
      SXYM=SXYM - ALFAM(4)
      SXZM=SXZM - ALFAM(5)
      SYZM=SYZM - ALFAM(6)
C
   50 WP1=CM*(SXM*(DEPS(1) - DPSC(1) - DPST) + SYM*(DEPS(2) - DPSC(2) -
     1   DPST) + SZM*(DEPS(3) - DPSC(3) - DPST) + SXYM*(DEPS(4) -
     2   DPSC(4)) + SXZM*(DEPS(5) - DPSC(5)) + SYZM*(DEPS(6) -
     3   DPSC(6)))

C
      WP2=(0.5*CD/CM)*(SXM*STRSSM(1) + SYM*STRSSM(2) + SZM*STRSSM(3)
     1     + 2.0*(SXYM*STRSSM(4) + SXZM*STRSSM(5) + SYZM*STRSSM(6)))
C
      DENMP=(XCON1*YLDM*YLDM)*(CM + EETM*XCON2)
C
   60 WP=WP1 + WP2
C
      IF(MODEL.EQ.11) GO TO 65
C
C     ISOTROPIC HARDENING *
C
      XLAMDA=(WP - (YLDM*XCON2)*(EPSTRM*EETD + YSD))/DENMP
      WPP=XLAMDA
      GO TO 70
C
C     KINEMATIC HARDENING *
C
   65 XLAMDA=(WP - (YLDM*YSD*XCON2))/DENMP
      WPP=XLAMDA
C
C     CHECK FOR UNLOADING OR NEUTRAL LOADING **
C
   70 IF(XLAMDA.GT.0.0) GO TO 75
      XLAMDA=0.0
      GO TO 80
C
   75 IF(KEY.EQ.2 .AND. IEQREF.NE.1) XLAMDA=XLAMDA - WP1/DENMP
C
   80 DPSP(1)=XLAMDA*SXM
      DPSP(2)=XLAMDA*SYM
      DPSP(3)=XLAMDA*SZM
      DPSP(4)=2.0*XLAMDA*SXYM
      DPSP(5)=2.0*XLAMDA*SXZM
      DPSP(6)=2.0*XLAMDA*SYZM
C
      XLAMDA=WPP
C
      IF(KEY.EQ.2 .AND. IEQREF.NE.1 .AND. XLAMDA.GE.0.0) GO TO 90
C
      SXM=SXT
      SYM=SYT
      SZM=SZT
      SXYM=SXYT
      SXZM=SXZT
      SYZM=SYZT
C
      RETURN
C
C        3. CALCULATE ELASTIC-PLASTIC CONSTITUTIVE MATRIX
C
   90 YLD1=YLDM
C
      SX1=SXM
      SY1=SYM
      SZ1=SZM
      SXY1=SXYM
      SXZ1=SXZM
      SYZ1=SYZM
C
      YIELD=YLD1*YLD1/(3.0*C2)
      GAMA1=1.0/(YIELD*(1.0 + EETM/(3.0*CM)))
C
      GAMA=GAMA1*SX1
      CEP(1,1)=A2 - GAMA*SX1
      CEP(1,2)=B2 - GAMA*SY1
      CEP(1,3)=B2 - GAMA*SZ1
      CEP(1,4)=   - GAMA*SXY1
      CEP(1,5)=   - GAMA*SXZ1
      CEP(1,6)=   - GAMA*SYZ1
C
      GAMA=GAMA1*SY1
      CEP(2,1)=CEP(1,2)
      CEP(2,2)=A2 - GAMA*SY1
      CEP(2,3)=B2 - GAMA*SZ1
      CEP(2,4)=   - GAMA*SXY1
      CEP(2,5)=   - GAMA*SXZ1
      CEP(2,6)=   - GAMA*SYZ1
C
      GAMA=GAMA1*SZ1
      CEP(3,1)=CEP(1,3)
      CEP(3,2)=CEP(2,3)
      CEP(3,3)=A2 - GAMA*SZ1
      CEP(3,4)=   - GAMA*SXY1
      CEP(3,5)=   - GAMA*SXZ1
      CEP(3,6)=   - GAMA*SYZ1
C
      GAMA=GAMA1*SXY1
      CEP(4,1)=CEP(1,4)
      CEP(4,2)=CEP(2,4)
      CEP(4,3)=CEP(3,4)
      CEP(4,4)=C2 - GAMA*SXY1
      CEP(4,5)=   - GAMA*SXZ1
      CEP(4,6)=   - GAMA*SYZ1
C
      GAMA=GAMA1*SXZ1
      CEP(5,1)=CEP(1,5)
      CEP(5,2)=CEP(2,5)
      CEP(5,3)=CEP(3,5)
      CEP(5,4)=CEP(4,5)
      CEP(5,5)=C2 - GAMA*SXZ1
      CEP(5,6)=   - GAMA*SYZ1
C
      GAMA=GAMA1*SYZ1
      CEP(6,1)=CEP(1,6)
      CEP(6,2)=CEP(2,6)
      CEP(6,3)=CEP(3,6)
      CEP(6,4)=CEP(4,6)
      CEP(6,5)=CEP(5,6)
      CEP(6,6)=C2 - GAMA1*SYZ1
C
      RETURN
C
      END
C *CDC* *DECK EMAT3
C *UNI* )FOR,IS  N.EMAT3, R.EMAT3
C
      SUBROUTINE EMAT3(TMP,PROP,PROPI,A1,B1,C1,D1,E1,F1,KKK)
C
C
C
C     THIS SUBROUTINE CALCULATES THE ELASTIC AND INVERSE ELASTIC
C     PROPERTIES FOR A SPECIFIED TEMPERATURE AND FORMS THE ELASTIC
C     CONSTITUTIVE MATRIX
C
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION PROP(16,1),PROPI(1)
C
C
C
C
C        1. INTERPOLATE MATERIAL PROPERTY TABLES
C
      CALL MTITP3(PROP,TMP,PROPI)
      YM=PROPI(1)
      PR=PROPI(2)
C
C        2. CALCULATE ELASTIC CONSTANTS
C
      A1=YM/(1.0 + PR)
      C1=A1*0.5
      A1=A1/(1.0 - 2.0*PR)
      B1=A1*PR
      A1=A1 - B1
      D1=PR/(PR - 1.0)
      E1=1.0/YM
      F1=-PR*E1
C
C        3. FORM ELASTIC CONSTITUTIVE MATRIX
C
   30 IF(KKK.EQ.1) RETURN
C
      DO 40 I=1,6
      DO 40 J=1,6
   40 C(I,J)=0.0
C
      C(1,1)=A1
      C(1,2)=B1
      C(1,3)=B1
      C(2,1)=B1
      C(2,2)=A1
      C(2,3)=B1
      C(3,1)=B1
      C(3,2)=B1
      C(3,3)=A1
      C(4,4)=C1
      C(5,5)=C1
      C(6,6)=C1
C
      RETURN
C
      END
C *CDC* *DECK MTITP3
C *UNI* )FOR,IS  N.MTITP3, R.MTITP3
C
      SUBROUTINE MTITP3(PROP,TMP,PROPI)
C
C
C
C     THIS SUBROUTINE LINEARLY INTERPOLATES THE MATERIAL PROPERTY
C     TABLES AND OBTAINS THE FOLLOWING PROPERTIES AT THE
C     SPECIFIED TEMPERATURE
C
C        YOUNGS MODULUS
C        POISSONS RATIO
C        VIRGIN MATERIAL YIELD STRESS
C        HARDENING MODULUS
C        MEAN COEFFICIENT OF THERMAL EXPANSION
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM3/ 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
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION PROP(16,1),PROPI(1)
C
C
C
C
C        1. ENTER TEMPERATURE TABLE AND DETERMINE
C           INTERPOLATION FACTOR
C
    5 IF(TMP.GE.RNGL) GO TO 10
      WRITE(6,3001)
      STOP
C
   10 L=0
      DO 20 K=2,NPTS
      L=L + 1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(TMP.GT.DUM) GO TO 20
      GO TO 25
   20 CONTINUE
      WRITE(6,3001)
      STOP
C
   25 XRATIO=(TMP - PROP(L,1))/(PROP(L + 1,1) - PROP(L,1))
C
C     CORRECT XRATIO FOR THE CASE WHEN TMP LIES OUTSIDE TABLE
C     BUT WITHIN THE TOLERANCE RANGE **
C
      IF(XRATIO.GT.1.0) XRATIO=1.0
      IF(XRATIO.LT.0.0) XRATIO=0.0
C
C        2. INTERPOLATE MATERIAL PROPERTIES
C
C     PROPI(J) CONTAINS INTERPOLATED VALUES **
C
C        PROPI(1) = YOUNGS MODULUS
C        PROPI(2) = POISSONS RATIO
C        PROPI(3) = VIRGIN MATERIAL YIELD STRESS
C        PROPI(4) = HARDENING MODULUS
C        PROPI(5) = MEAN COEFFICIENT OF THERMAL EXPANSION
C
      DO 30 M=2,6
   30 PROPI(M - 1)=PROP(L,M) + XRATIO*(PROP(L + 1,M) - PROP(L,M))
C
      RETURN
C
 3001 FORMAT(//,92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PRO
     1PERTY TEMPERATURES  (SUBROUTINE MTITP3))
C
      END
C *CDC* *DECK CREEP3
C *UNI* )FOR.IS  N.CREEP3, R.CREEP3
C
      SUBROUTINE CREEP3(DDT,DEPSC,TEMPD,EPSC,ORIG,NORG,STRESS,GAMA,
     1                  STRNR,PTIME2,EST,SX,SY,SZ,SXY,SXZ,SYZ,F,R,G,
     2                  INDEX,ECSTR)
C
C
C
C     THIS SUBROUTINE CALCULATES THE CREEP STRAIN RATE USING TOTAL
C     CREEP STRAIN HARDENING AND THE ORNL AUXILIARY HARDENING RULES FOR
C     CYCLIC CREEP
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SOLPM3/ 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
C
      DIMENSION DEPSC(6),ORIG(6,1),EPSC(1),STRESS(1)
C
C
C
      IMAX=50
      ETOL1=5.0D-3
      ETOL4=5.0D-6
      ETOL5=1.0D-20
C
C        1. CALCULATE THE CURRENT VALUE OF EFFECTIVE CREEP STRAIN
C
   10 CALL CYCRP3(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
      IF(EST.LE.TOL5) RETURN
C
      IF(KCRP.EQ.2) GO TO 20
C
C        2. ANALYTICAL SOLUTION FOR CREEP LAW NO. 1
C
      CALL CRPLW3(EST,ECSTR,STRN,STRNR,DDT,TEMPD,F,R,G)
      GO TO 60
C
C        3. NUMERICAL SOLUTION FOR CREEP LAW NO. 2
C
C
C     USE NEWTON ITERATION TO SOLVE FOR CURRENT EFFECTIVE
C     CREEP STRAIN RATE **
C
C
C     MAKE INITIAL GUESS OF PSEUDO-TIME *
C
   20 PTIME1=DBLE(FLOAT(KSTEP))*DTT + TSTART
      PTIME2=PTIME1
C
      KOUNT=1
   25 CALL CRPLW3(EST,ECSTR,STRN,STRNR,PTIME2,TEMPD,F,R,G)
C
      IMOD=0
      FUNCT=STRN-ECSTR
      DELTA=FUNCT/STRNR
      IF(ECSTR.EQ.0.0) DELTA=PTIME2
C
C     MODIFY DELTA, IF NECESSARY, TO OBTAIN A VALUE
C     OF PSEUDO-TIME .GE. 0.0 **
C
      IF((PTIME2 - DELTA).GE.0.0) GO TO 30
      DELTA=0.5*PTIME2
      IMOD=1
C
   30 IF(KOUNT.GT.1) GO TO 40
      PTIME2=PTIME1 - DELTA
      DNORM1=DABS(DELTA)
      KOUNT=KOUNT + 1
      GO TO 25
C
C     APPLY CONVERGENCE CRITERIA FOR KOUNT .GT.1 **
C
   40 DNORM2=DABS(DELTA)
      IF(IMOD.EQ.1) GO TO 50
      IF(DNORM2.LE.DNORM1) GO TO 45
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND **
C
      XTOL=ETOL4*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM2.LE.XTOL.AND.DNORM1.LE.XTOL) GO TO 60
      GO TO 50
C
   45 XTOL=ETOL1*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM1.LE.XTOL) GO TO 60
C
C     NO CONVERGENCE *
C
   50 KOUNT=KOUNT + 1
      IF(KOUNT.LE.IMAX) GO TO 55
      WRITE(6,2000)
      STOP
C
   55 PTIME1=PTIME2
      PTIME2=PTIME2 - DELTA
      DNORM1=DNORM2
      GO TO 25
C
C        4. CALCULATE INITIAL ESTIMATE OF INCREMENTAL CREEP STRAINS
C
   60 GAMA=1.5*STRNR/EST
      C1=GAMA*DDT
C
  100 DEPSC(1)=C1*SX
      DEPSC(2)=C1*SY
      DEPSC(3)=C1*SZ
      DEPSC(4)=C1*2.0*SXY
      DEPSC(5)=C1*2.0*SXZ
      DEPSC(6)=C1*2.0*SYZ
C
      RETURN
C
 2000 FORMAT(//,69H    ERROR   NEWTON ITERATION FAILED TO CONVERGE   (SU
     1BROUTINE CREEP3))
C
      END
C *CDC* *DECK CYCRP3
C *UNI* )FOR.IS  N.CYCRP3, R.CYCRP3
C
      SUBROUTINE CYCRP3(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
C
C
C
C     THIS SUBROUTINE PERFORMS THE ORNL-TM-3602 AUXILIARY STRAIN
C     HARDENING CALCULATIONS FOR CYCLIC CREEP
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        ORIG(I,J)   =  ARRAY CONTAINING POSITIVE ORIGIN IN THE FIRST
C                       COLUMN AND NEGATIVE ORIGIN IN THE SECOND
C        EPSD        =  DISTANCE BETWEEN CURRENT ORIGINS
C        EPSC(I)     =  CURRENT CREEP STRAIN COMPONENTS
C        NORG        =  DENOTES CURRENT ORIGIN
C                    =  1 POSITIVE ORIGIN
C                    =  2 NEGATIVE ORIGIN
C        STRESS(I)   =  CURRENT STRESSES
C        ECSTR       =  EFFECTIVE STRAIN MEASURE OF THE DISTANCE BETWEEN
C                       THE CURRENT CREEP STRAIN STATE AND ORIGIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION STRESS(1),EPSC(1),ORIG(6,1)
C
C
C     STRESS REVERSAL CAN OCCUR ONLY AT THE START OF A
C     SUBDIVISION (INDEX = 1)
C
      IF(INDEX.GT.1) GO TO 50
C
C
C        1. CALCULATE CURRENT DISTANCE BETWEEN ORIGINS
C
      CALL EFCST3(EPSD,ORIG,ORIG,2)
C
C        2. CHECK FOR STRESS REVERSAL
C
      DUM=0.0
      DO 15 I=1,6
   15 DUM=DUM+(EPSC(I)-ORIG(I,NORG))*STRESS(I)
      IF(DUM.GE.0.0) GO TO 50
C
C     STRESS REVERSAL IS INDICATED **
C
      CALL EFCST3(ECSTR,EPSC,ORIG,NORG)
C
C     CHECK IF OPPOSITE ORIGIN COORDINATES MUST BE RESET TO
C     NEW VALUES **
C
      IF(ECSTR.GT.EPSD) GO TO 40
C
C     CHECK FOR FALSE STRESS REVERSAL *
C
      IF(NORG.EQ.2) GO TO 18
   17 NN=2
      GO TO 19
   18 NN=1
   19 DUM=0.0
C
      DO 20 I=1,6
   20 DUM=DUM+(EPSC(I)-ORIG(I,NN))*STRESS(I)
      IF(DUM.GE.0.0) GO TO 25
C
C     FALSE REVERSAL IS INDICATED
C
      CALL EFCST3(TECSTR,EPSC,ORIG,NN)
      IF(ECSTR.GE.TECSTR) RETURN
C
C        3. RESET ORIGIN INDICATOR ONLY
C
   25 IF(NORG.EQ.2) GO TO 35
   30 NORG=2
      GO TO 50
   35 NORG=1
      GO TO 50
C
C        4. RESET ORIGIN INDICATOR AND COORDINATES
C
   40 IF(NORG.EQ.2) GO TO 42
   41 NORG=2
      GO TO 45
   42 NORG=1
C
   45 DO 48 I=1,6
   48 ORIG(I,NORG)=EPSC(I)
C
C        5. CALCULATE NEW VALUE OF EFFECTIVE CREEP STRAIN
C
   50 CALL EFCST3(ECSTR,EPSC,ORIG,NORG)
C
      RETURN
C
      END
C *CDC* *DECK EFCST3
C *UNI* )FOR,IS  N.EFCST3, R.EFCST3
C
      SUBROUTINE EFCST3(ECSTR,EPSC,ORIG,NORG)
C
C
C
C     THIS SUBROUTINE CALCULATES THE EFFECTIVE CREEP STRAIN BASED ON THE
C     DISTANCE BETWEEN THE CURRENT CREEP STRAIN STATE AND THE
C     CURRENT ORIGIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM3/ 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
C
      DIMENSION DEPSC(6),EPSC(1),ORIG(6,1)
C
C
C
      DO 10 I=1,6
   10 DEPSC(I)=EPSC(I)-ORIG(I,NORG)
C
      ECSTR=DSQRT(XCON1*(DEPSC(1)*DEPSC(1) + DEPSC(2)*DEPSC(2) +
     1           DEPSC(3)*DEPSC(3)) + XCON2*(DEPSC(4)*DEPSC(4)
     2           +DEPSC(5)*DEPSC(5)+DEPSC(6)*DEPSC(6)))
C
      RETURN
C
      END
C *CDC* *DECK CRPLW3
C *UNI* )FOR,IS  N.CRPLW3, R.CRPLW3
C
      SUBROUTINE CRPLW3(STRESS,ECSTR,STRAIN,STRNR,TIME,TEMPD,F,R,G)
C
C
C
C     THIS SUBROUTINE CONTAINS THE UNIAXIAL CREEP LAWS FOR MATERIAL
C     MODELS 10 AND 11  (3-D)
C
C
C     THE FOLLOWING VARIABLES ARE USED FOR THE UNIAXIAL LAWS
C
C        STRESS = UNIAXIAL STRESS
C        STRAIN = UNIAXIAL CREEP STRAIN
C        STRNR = UNIAXIAL CREEP STRAIN RATE
C        TIME = TIME
C        TEMPD = TEMPERATURE
C        CRPCON = CONSTANTS FOR UNIAXIAL CREEP LAW
C        ECSTR = MODIFIED EFFECTIVE CREEP STRAIN (O.R.N.L. RULES)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM3/ 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
C
C
C
      A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 50
C
C        1. CREEP LAW NO. 1
C
      IF(A2.GE.1.0) GO TO 20
C
      RTTOL=20.
      EX1=1./(1.-A2)
      EX2=A1*EX1
      EX3=A2*EX1
      EX4=-RTTOL*EX3
C
C     CALCULATE MINIMUM ALLOWABLE EFFECTIVE CREEP STRAIN **
C
      ECMIN=(A0**EX1)*(STRESS**EX2)*(A2**EX3)*(10.0**EX4)
      IF(ECSTR.LE.ECMIN) GO TO 40
C
   20 EX5=1.0/A2
      EX6=A1*EX5
      EX7=(A2-1.)/A2
      IF(A2.EQ.1.0.AND.ECSTR.EQ.0.0) GO TO 25
      EX8=ECSTR**EX7
      GO TO 30
   25 EX8=1.0
C
   30 STRNR=(A0**EX5)*(STRESS**EX6)*A2*EX8
C
      RETURN
C
   40 STRAIN=A0*(STRESS**A1)*(TIME**A2)
      STRNR=STRAIN/TIME
C
      RETURN
C
C        2. CREEP LAW NO. 2
C
   50 F=A0*DEXP(A1*STRESS)
      R=A2*((STRESS/A3)**A4)
      G=A5*DEXP(A6*STRESS)
      STRAIN=F*(1.-DEXP(-R*TIME)) + (G*TIME)
      STRNR=F*R*DEXP(-R*TIME) + G
C
      RETURN
C
      END
C *CDC* *DECK OVL47
C *CDC*       OVERLAY (ADINA,4,7)
C *CDC* *DECK EL3D12
C *UNI* )FOR,IS  N.EL3D12, R.EL3D12
C *CDC*       PROGRAM EL3D12
      SUBROUTINE EL3D12
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C      M O D E L S = 12 - 16
C
C
      RETURN
      END
C *CDC* *DECK OVL50
C *CDC*       OVERLAY (ADINA,5,0)
C *CDC* *DECK BEAM
C *UNI* )FOR,IS N.BEAM,R.BEAM
C *CDC*       PROGRAM BEAM
C
C
      SUBROUTINE BEAM
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                 .
C .   STORAGE                                                       .
C .                                                                 .
C .      N101  E        YOUNG'S  MODULUS                            .
C .      N102  G        SHEAR  MODULUS                              .
C .      N103  DEN      DENSITY                                     .
C .      N104  XI       SECOND MOMENT OF AREA ABOUT   R - AXIS      .
C .      N105  YI       SECOND MOMENT OF AREA ABOUT   S - AXIS      .
C .      N106  ZI       SECOND MOMENT OF AREA ABOUT   T - AXIS      .
C .      N107  AREA     NORMAL + SHEAR  SECTION  AREA               .
C .      N108  XYZ      ELEMENT  COORDINATE  ARRAY                  .
C .      N109  LM                                                   .
C .      N110  IPS      STRESS  OUTPUT  FLAG                        .
C .      N111  MATP                                                 .
C .      N112  PROP                                                 .
C .      N114  ISHEAR   FLAG  FOR  TRANSVERSE  SHEAR  EFFECTS       .
C .      N115  WA                                                   .
C .      N116  ITABLE   STRESS  OUTPUT  TABLES                      .
C .      N117  SR       GAUSS  ELIMINATION  COEFFICIENTS            .
C .      N124  ISKEW    NODAL SKEW COORDINATE SYSTEM                .
C .                                                                 .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      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 /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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 /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /DPR/ ITWO
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /STNL/ XLT,XOL,YOL,ZOL,FAC,PFAC,INTX,INTY,INTZ,NST
      COMMON /SKEW/ NSKEWS
      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
      EQUIVALENCE (NPAR(2),NUME),(NPAR(16),NUMMAT),(NPAR(17),NCON)
     1        ,(NPAR(15),MODEL),(NPAR(13),NTABLE),(NPAR(3),INDNL)
     2        ,(NPAR(4),IDEATH),(NPAR(14),JTABLE),(NPAR(12),NMOMNT)
      EQUIVALENCE (NPAR(5),ITYPB),(NPAR(6),NEGSKS),(NPAR(7),ISECT)
     1        ,(NPAR(1),NPAR1)
C
C
      DIMENSION WORD(2)
      DATA WORD /6HSTRESS , 6HFORCE  /
      INTX=NPAR(9)
      INTY=NPAR(10)
      INTZ=NPAR(11)
C
C
      IF (IND.GT.0) GO TO 275
C
C
C     I N P U T   P H A S E
C     C H E C K   T H E   N P A R   V E C T O R   F O R
C     R A N G E   A N D   C O M P A T I B I L I T Y
C
C
C
C     CHECK ON RANGE AND SET DEFAULTS FOR NPAR VECTOR
C
C
      ISTOP=0
      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,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   10 IF (INDNL.GE.0 .AND. INDNL.LT.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)
C
   15 IF (IDEATH.GE.0 .AND. IDEATH.LT.3) GO TO 20
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=4
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   20 IF (INDNL.EQ.0) GO TO 70
C
      IF (ITYPB.GE.0 .AND. ITYPB.LT.2) GO TO 25
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=5
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   25 IF (NEGSKS.EQ.0) GO TO 27
      IF (NSKEWS.GT.0) GO TO 27
      ISUB=6
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
C
   27 IF (ISECT.EQ.0) ISECT=1
      IF (ISECT.GT.0 .AND. ISECT.LT.3) GO TO 30
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=7
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
C
C
C     THE PROGRAM REQUIRES INTY=7 AND INTZ=7 WHEN A NONLINEAR
C     ANALYSIS OF A RECTANGULAR BEAM IS CARRIED OUT (FOR 3-D ACTION )
C
   30 IF ( ISECT.EQ.2 .OR. ITYPB.EQ.0 .OR. INDNL.EQ.0 ) GO TO 31
      IF (INTY.NE.0 .AND. INTY.NE.7) WRITE (6,3301)
      IF (INTZ.NE.0 .AND. INTZ.NE.7) WRITE (6,3302)
      INTY=7
      INTZ=7
C
   31 IF (INTX.GT.2 .OR. INTY.NE.0 .OR. INTZ.NE.0 ) GO TO 36
      INTX=5
      IF (ISECT-1) 32,32,34
   32 INTY=3
      INTZ=1
      IF (ITYPB.GT.0) INTZ=3
      GO TO 60
   34 INTY=1
      INTZ=7+ITYPB
      GO TO 60
C
   36 IF (INTX.LT.3) INTX=3
      IF (INTY.NE.0) GO TO 38
      IF (ISECT-1) 40,40,42
   40 INTY=3
      INTZ=1
      IF (ITYPB.GT.0) INTZ=3
      GO TO 60
   42 INTY=1
      INTZ=7+ITYPB
      GO TO 60
   38 IF (INTZ.EQ.0) INTZ=3
C
C
      IF (INTX.LT.8) GO TO 44
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=9
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   44 IF (INTY.LT.8) GO TO 46
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=10
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   46 KK=8
      IF (ISECT.EQ.2) KK=8+ITYPB
      IF (INTZ.LT.KK) GO TO 48
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=11
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   48 L=INTX - (INTX/2)*2
      IF (L.GT.0) GO TO 50
      INTX=INTX + 1
      WRITE (6,2010)
   50 L=INTY - (INTY/2)*2
      IF (L.GT.0) GO TO 52
      INTY=INTY + 1
      WRITE (6,2010)
   52 IF (ISECT.EQ.2) GO TO 60
      L=INTZ -(INTZ/2)*2
      IF (L.GT.0) GO TO 60
      INTZ=INTZ + 1
      WRITE (6,2010)
C
C
   60 NPAR(9)=INTX
      NPAR(10)=INTY
      NPAR(11)=INTZ
C
      IF (NMOMNT.GE.0) GO TO 65
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=12
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   65 IF (NTABLE.GE.-1) GO TO 70
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=13
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   70 IF (NTABLE.EQ. -1) JTABLE=12
      IF (JTABLE.EQ. 0) JTABLE=16
C
      IF (JTABLE.GT.0) GO TO 75
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=14
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   75 IF (MODEL.EQ.0) MODEL=1
      IF (MODEL.GT.0) GO TO 80
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=15
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
C
   80 IF (NUMMAT.GE.0) GO TO 81
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=16
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   81 IF (NUMMAT.EQ.0) NUMMAT=1
C
      NCONT=0
      IF (MODEL.EQ.2) GO TO 82
      IF (INDNL.GE.1 .AND. MODEL.EQ.1) NCONT=4
      NCON=NCONT
      GO TO 84
C
   82 NCONT=6
      IF (NCON.NE.0) GO TO 83
      NCON=NCONT
      GO TO 84
C
   83 IF (NCON.LE.6) GO TO 84
      ISTOP=ISTOP + 1
      ISUB=17
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
C
C
C     CHECK ON COMPATIBILITY BETWEEN ELEMENTS OF NPAR
C
C
C        1.     COMPATIBILITY OF INDNL AND IDEATH
C
   84 ISUB=3
      IF (INDNL.GT.0) GO TO 90
      IF (IDEATH.EQ.0) GO TO 85
      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        2.     COMPATIBILITY OF INDNL AND MODEL
C
   85 IF (MODEL.EQ.1) GO TO 90
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=15
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C        3.     COMPATIBILITY OF NEGSKS AND NSKEWS
C
   90 IF (NEGSKS.EQ.0) GO TO 95
      IF (NSKEWS.GT.0) GO TO 95
      ISUB=6
      ISTOP=ISTOP + 1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
C
C
C
   95 IF (ISTOP.GT.0) IDATWR=1
      IF (IDATWR.GT.1) GO TO 100
C
C     P R I N T   O U T   N P A R   V E C T O R
C
      WRITE (6,2099) NPAR1
      WRITE (6,2015) NUME,INDNL,IDEATH
      IF (INDNL.GT.0) GO TO 5
      WRITE (6,2012) NEGSKS,NMOMNT
      GO TO 4
C
    5 WRITE (6,2004) ITYPB,NEGSKS,ISECT
      IWORD=1
      IF (NTABLE.EQ. -1) IWORD=2
      WRITE (6,2014) INTX,INTY,INTZ,NMOMNT,NTABLE,WORD(IWORD),JTABLE
    4 WRITE (6,2001) MODEL,NUMMAT,NCON
      IF (INDNL.GT.1) WRITE (6,2698)
C
  100 IF (ISTOP.EQ.0) GO TO 275
      WRITE (6,2750)
      STOP
C
C
  275 NST=11
      IF (MODEL.EQ.1) NST=3
      IDWA=INTX*INTY*NPAR(11)*NST
      IF (INDNL.EQ.2) IDWA=IDWA + 1
      NMAT=0
      IF (INDNL.EQ.0) NMAT=NUMMAT
      INSR = 6 + 48*ITYPB
C
      NFIRST=N6
      IF(IND.EQ.4) NFIRST=N10
      N101=NFIRST + 20
      N102=N101 + NMAT*ITWO
      N103 = N102 + NMAT*ITWO
      N104 = N103 + NUMMAT*ITWO
      N105 = N104 + NMAT*ITWO
      N106 = N105 + NMAT*ITWO
      N107 = N106 + NMAT*ITWO
      N108 = N107 + 3*NMAT*ITWO
      N109 = N108 + 9*NUME*ITWO
      N110 = N109 + 12*NUME
      N111 = N110 + NUME
      N112 = N111 + NUME
C
      NFAC=1
      IF (NMAT.GT.0) NFAC=0
      N114 = N112 + NFAC*NCON*NUMMAT*ITWO
      N115 = N114 + NFAC*NUMMAT
      N116 = N115 + NFAC*IDWA*NUME*ITWO
      NTAB=NTABLE
      IF (NTABLE.LT.0) NTAB=0
      LL=JTABLE/16
      LLL=JTABLE - LL*16
      IF (LLL.GT.0) LL=LL + 1
      LL=LL*16
      N117 = N116 + LL*NFAC*NTAB
      N118 = N117 + INSR*NFAC*NUME*ITWO
C
      MM=0
      IF (IDEATH.GT.0) MM=1
      N119 = N118 + MM*NUME*ITWO
      MM=0
      IF (IDEATH.EQ.1) MM=1
      N120 = N119 + 12*MM*NUME*ITWO
      N121 = N120 + 6*NMOMNT
      N122 = N121 + NUME
      IF (NMOMNT.EQ.0) N122=N121
      N123 = N122 + 12*NUME*ITWO
      N124=N123 + NUME*ITWO
      IF (INDNL.EQ.0) N124=N122
      MM=0
      IF (NEGSKS.GT.0) MM=1
      N125=N124 + MM * (2*NUME)
      MM=1
      IF (NMOMNT.EQ.0) MM=0
      N126 = N125 + 36*MM*NFAC*NUME*ITWO
      MM=1
      IF (INDNL .EQ. 0) MM=0
      N127 = N126 + 8*MM*NUME*ITWO
      NLAST = N127 - 1
C
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
      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=N2
      M3=N7
      M4=N8
      IF (ICOUNT.LT.3) GO TO 120
      M2=N6
C
  120 CALL BMEL   (A(N06),A(N1A),
     1          A(N1),A(M2),A(M3),A(M4),A(N5),A(N101),A(N102),A(N103),
     1          A(N104),A(N105),A(N106),A(N107),A(N108),A(N109),
     2          A(N110),A(N111),A(N112),A(N114),A(N115),A(N116)
     3         ,A(N117),A(N118),A(N119),A(N120),A(N121),A(N122),A(N123),
     4          A(N124),A(N125),A(N126),
     5          NCON,NDOF,IDWA,NTAB,NMOMNT,INSR)
C
      RETURN
C
C
C
 2099 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/,
     6         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   /)
 2015 FORMAT (20H NUMBER OF ELEMENTS.,10(2H .),16H( NPAR(2) ). . =,I5//,
     9       28H TYPE OF NONLINEAR ANALYSIS.,6(2H .),16H( NPAR(3) ). . =
     A,      I5/,
     "       40H     EQ.0, LINEAR ELASTIC ONLY                    /,
     B       38H     EQ.1, MATERIALLY NONLINEAR ONLY  /,
     C        45H     EQ.2, UPDATED LAGRANGIAN FORMULATION         //,
     D       32H ELEMENT BIRTH AND DEATH OPTIONS ,4(2H .),
     E       16H( NPAR(4) ). . =,I5/,
     F       40H     EQ.0, OPTION NOT ACTIVE                   /,
     G       40H     EQ.1, BIRTH OPTION ACTIVE                 /,
     H       40H     EQ.2, DEATH OPTION ACTIVE                  //)
 2001 FORMAT (42H 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        40H    EQ.1,   LINEAR ELASTIC                          /,
     3        40H    EQ.2,  ELASTIC-PLASTIC                         //,
     5        40H 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)
 2004 FORMAT (18H ELEMENT TYPE CODE,11(2H .),16H( NPAR(5) ). . =,I5/,
     1        40H     EQ.0, IN-PLANE BEAM                           /,
     2        45H     EQ.1, GENERAL 3-D BEAM                       //,
     2        23H SKEW COORDINATE SYSTEM  /
     3        24H     REFERENCE INDICATOR ,8(2H .),
     3        16H( NPAR(6) ). . =,I5/
     4        28H     EQ.0, ALL ELEMENT NODES  /
     5        37H           USE THE GLOBAL SYSTEM ONLY  /
     6        35H     EQ.1, ELEMENT NODES REFER       /
     7        36H           TO SKEW COORDINATE SYSTEM  //,
     X        28H SECTION IDENTIFICATION FLAG,6(2H .),
     Y        16H( NPAR(7) ). . =,I5/,
     Z        40H     EQ.1, RECTANGULAR SECTION                     /,
     *        40H     EQ.2, PIPE SECTION                          ///)
 2014 FORMAT (40H INTEGRATION ORDER IN   R   DIRECTION. .        ,
     1        16H( NPAR(9) ). . =,I5//,
     2        40H INTEGRATION ORDER IN   S   DIRECTION. .     ,
     3        16H( NPAR(10)). . =,I5//,
     2        40H INTEGRATION ORDER IN   T   DIRECTION. .     ,
     5        16H( NPAR(11)). . =,I5////,
     P        32H NUMBER OF MOMENT RELEASE TABLES  ,4(2H .),
     Q        16H( NPAR(12)). . =,I5///,
     6        40H NUMBER OF STRESS OUTPUT TABLES               ,
     7        16H( NPAR(13)). . =,I5/,
     8        30H    EQ.-1, PRINT NODAL FORCES     ,/,
     8        49H    EQ. 0, PRINT AT ALL INTEGRATION POINTS        ,//,
     9        15H MAXIMUM NO OF ,A6,18H OUTPUT LOCATIONS        ,/,
     A        14H    IN A TABLE,13(2H .),16H( NPAR(14)). . =,I5////)
 2012 FORMAT (23H SKEW COORDINATE SYSTEM  /
     3        24H     REFERENCE INDICATOR ,8(2H .),
     3        16H( NPAR(6) ). . =,I5/
     1        28H     EQ.0, ALL ELEMENT NODES  /
     2        37H           USE THE GLOBAL SYSTEM ONLY  /
     3        35H     EQ.1, ELEMENT NODES REFER       /
     3        36H           TO SKEW COORDINATE SYSTEM  //,
     4        32H NUMBER OF MOMENT RELEASE TABLES  ,4(2H .),
     1        16H( NPAR(12)). . =,I5///)
 2100 FORMAT (1H1,45HERROR IN ELEMENT GROUP CONTROL CARDS  (BEAM)  /
     1        16H ELEMENT GROUP =, I5/)
 2200 FORMAT (I5,7H. NPAR(,I2,27H) IS OUT OF RANGE ... NPAR(,I2,
     1        3H) =,I5)
 2400 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .GE., I2,10H ... NPAR(,I2,
     1        3H) =,I5)
 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 )
 2750 FORMAT (//// 23H STOP  (ERROR IN NPAR)  )
 2010 FORMAT (//45H **WARNING** INCORRECT INTEGRATION ORDER        //)
 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/
     2        12H DATA (GROUP,I3,2H).,12(2H .),15H( MIDEST ). . =,I5)
 2698 FORMAT (////16H *** N O T E ***//
     1  52H IN GEOMETRIC NONLINEAR ANALYSIS, I.E., INDNL.GT.1, /
     2  52H THE TOTAL ROTATIONS AT THE NODAL POINTS PRINTED IN /
     3  52H THE STEP-BY-STEP SOLUTION ARE NOT USED.            //
     4  52H THE ELEMENT KINEMATICS AND STRESSES ARE CALCULATED /
     5  52H USING INCREMENTAL ROTATIONS.                       ///)
 3301 FORMAT (//15H *** NOTE ***      /
     1          45H INTEGRATION ORDER IN THE S-DIRECTION           /
     2          45H HAS BEEN RE-SET TO  7.                         /)
 3302 FORMAT (//15H *** NOTE ***      /
     1          45H INTEGRATION ORDER IN THE T-DIRECTION           /
     2          45H HAS BEEN RE-SET TO  7.                         /)
C
      END
C *CDC* *DECK BMEL
C *UNI* )FOR,IS N.BMEL,R.BMEL
      SUBROUTINE BMEL (RSDCOS,NODSYS,ID,X,Y,Z,HT,E,G,DEN,XI,YI,ZI,
     1                 AREA,XYZ,LM,IPS,MATP,PROP,ISHEAR,WA,ITABLE,
     2                 SR,ETIMV,EDISP,IMOMNT,IELRET,PDISP,GAMA,ISKEW,
     3                 SREL,RERIT,
     3                 NCON,NDOF,IDWA,NTAB,NMOMNT,INSR)
C
C
C     SUBROUTINE TO CALCULATE BEAM ELEMENT MATRICES AND
C     ELEMENT STRESSES
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1      ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /EMBM/ S(78),XM(12),STR(78),D(3),AS(16,16),BS(3,3)
      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 /RANDI/ N0A,N1D,IELCPL
      COMMON /MDFRDM/ IDOF(6)
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /STNL/ XLT,XOL,YOL,ZOL,FAC,PFAC,INTX,INTY,INTZ,NST
      COMMON /BTRANS/ DISP(16),DXYZ(9),XLN,EPS,EPS1
      COMMON /POS/ I1,I2,I3,ISTRES
      COMMON /PIE/ PI,TOPI,DEGRAD,RADEG
      COMMON /SKEW/ NSKEWS
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      COMMON A(1)
      REAL A
C
      DIMENSION X(1),Y(1),Z(1),ID(NDOF,1),E(1),DEN(1),AREA(3,1),LM(12,1)
     1       ,XYZ(9,1),MATP(1),PROP(NCON,1),G(1),XI(1),YI(1),ZI(1)
      DIMENSION IPS(1),HT(1),ITABLE(NTAB,1),SR(INSR,1)
      DIMENSION T(3,3),WA(IDWA,1),ISHEAR(1),WORD(2),RE(16) ,
     1          ETIMV(1),EDISP(12,1),IMOMNT(6,NMOMNT),IELRET(1)
      DIMENSION PDISP(12,1),GAMA(1),ISKEW(2,1),RSDCOS(9,1),NODSYS(1)
     1          ,ILSK(4),ILTK(4),ILRK(4),SREL(36,1),RERIT(8,1)
      DIMENSION IPICK(7),XYZINT(3,392)
C
      EQUIVALENCE (NPAR(1),NPAR1),(NPAR(2),NUME),(NPAR(16),NUMMAT)
     1        ,(NPAR(15),MODEL),(NPAR(3),INDNL),(NPAR(4),IDEATH)
      EQUIVALENCE (NPAR(14),JTABLE),(NPAR(5),ITYPB),(NPAR(6),NEGSKS)
      EQUIVALENCE (NPAR(7),ISECT),(NPAR(13),NTABLE)
C
C
C    **NOTE**  DURING THE TIME INTEGRATION, X=DISP, Y=VEL, Z=ACC, HT=R
C
C     IF SKEW COORDINATE SYSTEMS ARE EMPLOYED IN THE U.L.
C     FORMULATION, EDISP AND PDISP TRANSLATIONS ARE
C     IN THE GLOBAL SYSTEM. HOWEVER, ONLY INCREMENTAL ROTATIONS
C     ARE ROTATED TO THE GLOBAL SYSTEM, I.E. EDISP AND
C     PDISP ROTATION COMPONENTS ARE IN THE SKEW SYSTEM.
C     GIVEN DISP, TRANSLATIONS ARE ROTATED IMMEDIATELY,
C     ROTATIONS ARE ROTATED ONLY AFTER THE INCREMENTS ARE FOUND.
C
C
      DATA IPICK /0,1,-1,2,-2,3,-3/
      DATA WORD/7HELASTIC,8H*PLASTIC/
      DATA RECLB1/8HTYPE-4  /, RECLB2/8HMATERAL4/, RECLB3/8HSECTION4/,
     1     RECLB4/8HOUTABLE4/, RECLB5/8HELEMENT4/, RECLB6/8HNEWSTEP4/,
     2     RECLB7/8HOUTPUT-4/, RECLB8/8HIPOINT-4/
C
      ND=12
      NPTS=JTABLE
C
      IELCPL=0
      IF (KPRI.EQ.0) GO TO 800
      IF (IND.GT.0) GO TO 420
      IJPORT=1
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) IJPORT=0
C
C***  DATA PORTHOLE (START)
C
      RECLAB=RECLB1
      IF (IJPORT.EQ.1)
     1 WRITE (LU1) RECLAB,NG,(NPAR(I),I=1,20),NSUB
C
C***  DATA PORTHOLE (END)
C
C
C     R E A D  A N D  G E N E R A T E  E L E M E N T
C     I N F O R M A T I O N
C
C
      IBUG=0
      IF (INDNL) 1,1,2
C
C     MATERIAL DATA
C
    1 IF (IDATWR.LE.1) WRITE (6,2002)
      DO 10 I=1,NUMMAT
      READ(5,1000) N,E(N),XNU,DEN(N)
      G(N)=E(N)/(2.*(1. + XNU))
      READ(5,1001) XI(N),YI(N),ZI(N),AREA(1,N),AREA(2,N),AREA(3,N)
   10 CONTINUE
      IF (IDATWR.GT.1) GO TO 30
      DO 9 N=1,NUMMAT
      XNU=E(N)/(2.*G(N))-1.0
    9 WRITE (6,2003) N,E(N),XNU,DEN(N)
      WRITE (6,2010)
      DO 11 N=1,NUMMAT
      WRITE(6,2009) N,XI(N),YI(N),ZI(N),AREA(1,N),AREA(2,N),AREA(3,N)
   11 CONTINUE
      GO TO 30
C
    2 IF (IDATWR.LE.1) WRITE (6,2020)
      DO 14 I=1,NUMMAT
      READ (5,1010) N,ISHEAR(N),DEN(N)
      IF (ISHEAR(N).LE.1) GO TO 22
      IBUG=1
      WRITE (6,3000) N,ISHEAR(N)
   22 READ (5,1011) (PROP(J,N),J=1,NCON)
      IF (ISECT.NE.2 .OR. PROP(4,N).LT.PROP(3,N)) GO TO 14
      IBUG=1
      WRITE (6,3401) NG,N
   14 CONTINUE
      DO 15 I=1,NUMMAT
   15 IF (IDATWR.LE.1) WRITE (6,2021) I,ISHEAR(I),DEN(I)
C
      IF (MODEL.EQ.2) GO TO 16
      IF (IDATWR.GT.1) GO TO 30
      WRITE (6,2030)
      DO 12 N=1,NUMMAT
   12 WRITE (6,2023) N,(PROP(I,N),I=1,NCON)
      GO TO 30
C
   16 IF (NCON.GT.6) GO TO 18
      IF (IDATWR.LE.1) WRITE (6,2022)
      DO 17 N=1,NUMMAT
      IF (PROP(5,N).GT.0.0) GO TO 41
      IBUG=1
      WRITE (6,3402) NG,N
   41 IF (PROP(6,N).LT.PROP(1,N)) GO TO 42
      IBUG=1
      WRITE (6,3403) NG,N
   42 IF (IDATWR.LE.1) WRITE (6,2023) N,(PROP(I,N),I=1,NCON)
   17 CONTINUE
      GO TO 30
C
   18 WRITE (6,2100)
      DO 19 N=1,NUMMAT
      WRITE (6,2110) N,(PROP(I,N),I=1,6)
      DO 13 J=8,NCON,2
      ET=(PROP(J-1,N) - PROP(J-3,N))/(PROP(J,N) - PROP(J-2,N))
   13 WRITE (6,2120) PROP(J-1,N),PROP(J,N),ET
   19 CONTINUE
   30 IF (MODEX.EQ.0 .OR. IBUG.EQ.0) GO TO 31
      WRITE (6,3404)
      STOP
C
C     ELEMENT END RELEASE TABLES
C
   31 IF (NMOMNT.EQ.0) GO TO 20
      IF (IDATWR.LE.1) WRITE (6,2210)
      DO 32 I=1,NMOMNT
      READ (5,1050) (IMOMNT(J,I),J=1,6)
   32 IF (IDATWR.LE.1) WRITE (6,2220) I,(IMOMNT(J,I),J=1,6)
C
C     READ TABLES FOR ELEMENT STRESS OUTPUT LOCATION
C
   20 IF (NTABLE.LE.0) GO TO 40
      L=JTABLE/16
      LL=JTABLE - 16*L
      IF (LL.GT.0) L=L + 1
      DO 25 I=1,NTABLE
      IF (IDATWR.LE.1) WRITE (6,2200) I
      K=0
      DO 24 J=1,L
      K=K + 1
      KK=K + 15
      READ (5,1009)(ITABLE(I,JJ),JJ=K,KK)
      IF (IDATWR.LE.1) WRITE (6,2201) (ITABLE(I,JJ),JJ=K,KK)
      DO 23 JJ=K,KK
      IF (ITABLE(I,JJ).EQ.0) GO TO 25
   23 CONTINUE
   24 K=KK
   25 CONTINUE
   40 IF (IDATWR.LE.1) WRITE (6,2011)
C
C***  DATA PORTHOLE (START)
C
      IF (IJPORT.EQ.0) GO TO 90
      IF (INDNL.GT.0) GO TO 70
      RECLAB=RECLB2
      DO 50 N=1,NUMMAT
      XNU=E(N)/(2.*G(N))-1.
   50 WRITE (LU1) RECLAB,E(N),XNU,DEN(N)
      RECLAB=RECLB3
      WRITE (LU1)  RECLAB,NUMMAT,(XI(I),YI(I),ZI(I),AREA(1,I),
     2             AREA(2,I),AREA(3,I),I=1,NUMMAT)
      GO TO 80
C
   70 RECLAB=RECLB2
      WRITE (LU1)  RECLAB,NUMMAT,NCON,(DEN(I),I=1,NUMMAT),
     1             ((PROP(I,J),I=1,NCON),J=1,NUMMAT)
      RECLAB=RECLB3
      WRITE (LU1)  RECLAB,NUMMAT,(ISHEAR(I),I=1,NUMMAT)
C
   80 RECLAB=RECLB4
      IF (NTABLE.LE.0)
     1 WRITE (LU1)  RECLAB,NTABLE
      IF(NTABLE.GT.0)
     1 WRITE(LU1) RECLAB,NTABLE,((ITABLE(I,J),I=1,NTAB),J=1,NPTS)
C
C***  DATA PORTHOLE (END)
C
   90 N=1
      IREAD=5
      IF (INPORT.GT.0) IREAD=59
      ISCONT=0
      IF (NEGSKS.EQ.0 .AND. NSKEWS.GT.0) ISCONT=1
  100 READ (IREAD,1002) M,II,JJ,KK,MTYP,IS,KG,ETIME,IELRE,INTLOC
      IF (N.EQ.1 .AND. M.NE.1) GO TO 115
      IF (KG.EQ.0) KG=1
      IF (IDEATH.EQ.2 .AND. ETIME.EQ.0.D0) ETIME=1.D8
  120 IF (M.NE.N) GO TO 200
      K=KK
      I=II
      J=JJ
      MTYPE=MTYP
      KKK=KG
      IPST= IS
      ETIM=ETIME
      IELREM=IELRE
      INTLM=INTLOC
C
C     SAVE ELEMENT INFORMATION
C
  200 XYZ(1,N)=X(I)
      XYZ(2,N)=Y(I)
      XYZ(3,N)=Z(I)
C
      XYZ(4,N)=X(J)
      XYZ(5,N)=Y(J)
      XYZ(6,N)=Z(J)
C
      XYZ(7,N)=X(K)
      XYZ(8,N)=Y(K)
      XYZ(9,N)=Z(K)
C
      IF (ISCONT.EQ.0) GO TO 203
      IF (NODSYS(I).EQ.0 .AND. NODSYS(J).EQ.0) GO TO 205
      WRITE (6,2410) NG,N,NEGSKS
      STOP
  115 WRITE (6,3500) NSUB,NG
      STOP
  203 IF (NEGSKS.EQ.0) GO TO 205
      ISKEW(1,N)=NODSYS(I)
      ISKEW(2,N)=NODSYS(J)
      IF (NODSYS(I).EQ.0 .AND. NODSYS(J).EQ.0) ISKEW(1,N)=-1
  205 CONTINUE
C
      MATP(N)=MTYPE
      IPS(N) = IPST
      IF (NMOMNT.GT.0) IELRET(N)=IELREM
C
C
      IF (IDEATH.EQ.0) GO TO 210
      IF (IDEATH.EQ.2) GO TO 206
      DO 208 L=1,12
  208 EDISP(L,N)=0.
      ETIMV(N)=-ETIM
      GO TO 210
  206 ETIMV(N)=ETIM
C
  210 LL=1
      DO 211 L=1,6
      LM(L,N)=0
      LM(L+6,N)=0
      IF (IDOF(L) .EQ. 1) GO TO 211
      LM(L,N)=ID(LL,I)
      LM(L+6,N)=ID(LL,J)
      LL=LL+1
  211 CONTINUE
C
C     UPDATE COLUMN HEIGHTS AND BANDWIDTH
C
      CALL COLHT (HT,ND,LM(1,N))
C
      IF (IDATWR.LE.1)
     1  WRITE (6,2005) N,I,J,K,MTYPE,IPST,KKK,ETIM,IELREM,INTLM
      IF (IJPORT.EQ.0 .AND. INTLM.EQ.0) GO TO 249
C
C     CALCULATE GLOBAL COORDINATES OF INTEGRATION POINTS
C     NOT APPLICABLE FOR LINEAR ELEMENTS
C
      IF (INDNL.LE.0) GO TO 229
      NPT=INTX*INTY*INTZ
      TOL=1.D-8
C
C     CALCULATE UNIT VECTORS IN THE R,S AND T DIRECTIONS
C
      RX=X(J) - X(I)
      RY=Y(J) - Y(I)
      RZ=Z(J) - Z(I)
      DUM=DSQRT(RX*RX + RY*RY + RZ*RZ)
      IF (DUM.GT.TOL) GO TO 219
      WRITE (6,3010) NG,N
      STOP
  219 RX=RX/DUM
      RY=RY/DUM
      RZ=RZ/DUM
      AX=X(K) - X(I)
      AY=Y(K) - Y(I)
      AZ=Z(K) - Z(I)
      TX=RY*AZ - RZ*AY
      TY=RZ*AX - RX*AZ
      TZ=RX*AY - RY*AX
      DUM=DSQRT(TX*TX + TY*TY + TZ*TZ)
      IF (DUM.GT.TOL) GO TO 221
      WRITE (6,3011) NG,N
      STOP
  221 TX=TX/DUM
      TY=TY/DUM
      TZ=TZ/DUM
      SX=TY*RZ - TZ*RY
      SY=TZ*RX - TX*RZ
      SZ=TX*RY - TY*RX
C
      CALL LENGTH (XLT,XYZ(1,N))
C
      IX=INTX-1
      IF (IX.EQ.0) IX=1
      IY=INTY-1
      IF (IY.EQ.0) IY=1
      IZ=INTZ-1
      IF (IZ.EQ.0) IZ=1
      IF (INTZ.EQ.8) IZ=8
      XINT=0.5*(X(I) + X(J))
      YINT=0.5*(Y(I) + Y(J))
      ZINT=0.5*(Z(I) + Z(J))
      DSECT1=PROP(3,MTYPE)
      DSECT2=PROP(4,MTYPE)
      DRINT=XLT/DBLE(FLOAT(IX))
      IF (ISECT.EQ.2) GO TO 213
C
C     RECTANGULAR SECTION GEOMETRY
C
      DSINT=DSECT1/DBLE(FLOAT(IY))
      DTINT=DSECT2/DBLE(FLOAT(IZ))
      GO TO 214
C
C     PIPE SECTION GEOMETRY
C
  213 RMEAN=0.5*(DSECT1 + DSECT2)
      DRAD=0.5*(DSECT1 - DSECT2)
      DANG=4.*DATAN(1.D0)/DBLE(FLOAT(IZ))
      IF (INTZ.EQ.8) DANG=DANG*2.
C
C     CALCULATE LOCATION  OF INTEGRATION POINTS
C
  214 KINTP=0
      DO 228 I1=1,INTX
      RINTP=IPICK(I1)*DRINT
      IF (ISECT.EQ.2) GO TO 222
C
C     BEAM WITH RECTANGULAR SECTION
C
      DO 220 I2=1,INTY
      SINTP=IPICK(I2)*DSINT
      DO 220 I3=1,INTZ
      TINTP=IPICK(I3)*DTINT
      KINTP=KINTP+1
      XYZINT(1,KINTP)=XINT + RX*RINTP + SX*SINTP + TX*TINTP
      XYZINT(2,KINTP)=YINT + RY*RINTP + SY*SINTP + TY*TINTP
      XYZINT(3,KINTP)=ZINT + RZ*RINTP + SZ*SINTP + TZ*TINTP
C
C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
C
      IF (IDATWR.GT.1 .OR. INTLM.LE.0) GO TO 220
      WRITE (6,2310) I1,I2,I3,(XYZINT(L,KINTP),L=1,3)
  220 CONTINUE
      GO TO 228
C
C     BEAM WITH PIPE SECTION
C
  222 DO 226 I2=1,INTY
      SINT=RMEAN + IPICK(I2)*DRAD
      DO 226 I3=1,INTZ
      TINT=(I3-1)*DANG
      SINTP=SINT*DCOS(TINT)
      TINTP=SINT*DSIN(TINT)
      KINTP=KINTP+1
      XYZINT(1,KINTP)=XINT + RX*RINTP + SX*SINTP + TX*TINTP
      XYZINT(2,KINTP)=YINT + RY*RINTP + SY*SINTP + TY*TINTP
      XYZINT(3,KINTP)=ZINT + RZ*RINTP + SZ*SINTP + TZ*TINTP
C
C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
C
      IF (IDATWR.GT.1 .OR. INTLM.LE.0) GO TO 226
      WRITE (6,2310) I1,I2,I3,(XYZINT(L,KINTP),L=1,3)
  226 CONTINUE
  228 CONTINUE
      GO TO 230
  229 IF (INTLM.GT.0) WRITE (6,3013)
C
C***  DATA PORTHOLE (START)
C
  230 IF (IJPORT.EQ.0) GO TO 249
      RECLAB=RECLB5
      WRITE (LU1) RECLAB,N,I,J,K,MTYPE,IPST,ETIM,IELREM,INTLM
      RECLAB = RECLB8
      IF (INDNL.GT.0)
     1  WRITE (LU1) RECLAB,NPT,((XYZINT(L,I),L=1,3),I=1,NPT)
  249 CONTINUE
C
C***  DATA PORTHOLE (END)
C
      IF (N.EQ.NUME) GO TO 250
      N=N+1
      I=I+KKK
      J=J+KKK
      IF (N.GT.M) GO TO 100
      GO TO 120
  250 IF (INDNL.EQ.0) GO TO 262
C
C     INITIALIZE WORKING ARRAYS
C
      DO 252 N=1,NUME
C
      GAMA(N)=0.
      DO 216 L=1,ND
  216 PDISP(L,N)=0.
C
      MTYPE=MATP(N)
C
C     SR ARRAY CONTAINS THE GAUSS ELIMINATION COEFFICIENTS.
C
C     JNSR ARE THE NUMBER OF ENTRIES IN THE SR MATRIX.
C
      IF ( ( ISHEAR(MTYPE) + ITYPB ).EQ. 0) GO TO 253
      JNSR = 6 + ( 19*ITYPB + 29*ISHEAR(MTYPE) )*ITYPB
      DO 254 L=1,JNSR
  254 SR(L,N)=0.
      DO 218 I=1,8
  218 RERIT(I,N)=0.0
  253 DO 255 I=1,IDWA
  255 WA(I,N)=0.
      IF (MODEL.EQ.1)GO TO 252
      IST=1 - NST
      IF (INDNL.EQ.2) IST=IST + 1
      MTYPE=MATP(N)
      DO 260 I1=1,INTX
      DO 260 I3=1,INTZ
      DO 260 I2=1,INTY
      IST=IST + NST
  260 WA(IST,N)=-PROP(5,MTYPE)
  252 CONTINUE
      IF (NMOMNT.EQ.0) GO TO 262
      DO 245 N=1,NUME
      DO 245 I=1,36
  245 SREL(I,N)=0.
  262 IF (NEGSKS.EQ.0) GO TO 275
      DO 265 N=1,NUME
      IF (ISKEW(1,N).GE.0) GO TO 270
  265 CONTINUE
      WRITE (6,2400) NG,NEGSKS
  270 CONTINUE
C
  275 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 ITONLY=0
      DO 500 N=1,NUME
C
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 500
C
      MTYPE = MATP(N)
      CALL LENGTH (XLT,XYZ(1,N))
      CALL STIFF (AS,XLT,E(MTYPE),G(MTYPE),XI(MTYPE),YI(MTYPE),
     1            ZI(MTYPE),AREA(1,MTYPE))
C
      IF (NMOMNT.EQ.0) GO TO 445
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 445
      CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
  445 CONTINUE
C
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
      K= 0
      DO 530 I= 1,12
      DO 530 J=I,12
      K= K+1
  530 S(K)= AS(I,J)
C
      IF (NEGSKS.EQ.0) GO TO 520
      IF (ISKEW(1,N).LT.0) GO TO 520
      ILSK(1)=ISKEW(1,N)
      ILSK(2)=ILSK(1)
      ILSK(3)=ISKEW(2,N)
      ILSK(4)=ILSK(3)
      CALL ATKA (RSDCOS,S,ILSK,4,3)
  520 CONTINUE
C
      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 X
C
C
  560 GO TO (545,550),IMASS
C
C     LUMPED  MASS  DISCRETIZATION
C
  545 DO 546 N=1,NUME
      MTYPE=MATP(N)
      CALL LENGTH (XLT,XYZ(1,N))
      IF (INDNL.NE.0) GO TO 547
      XAREA=AREA(1,MTYPE)
      GO TO 548
  547 XAREA=PROP(3,MTYPE)*PROP(4,MTYPE)
      IF (ISECT.LE.1) GO TO 548
      XAREA=PI*(PROP(3,MTYPE)**2 - PROP(4,MTYPE)**2)/4.
C
  548 XMM=XLT*XAREA*DEN(MTYPE)/2.
      DO 549 L=1,3
      XM(L)= XMM
      XM(L+3)=0.
      XM(L+6)=XMM
  549 XM(L+9)=0.
      CALL ADDMA (A(N4),XM,LM(1,N),ND)
  546 CONTINUE
      RETURN
C
C     CONSISTENT MASS DISCRETIZATION
C
  550 ITONLY=0
      DO 670 N=1,NUME
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 670
      MTYPE=MATP(N)
      CALL LENGTH (XLT,XYZ(1,N))
      IF (INDNL.NE.0) GO TO 562
      XAREA=AREA(1,MTYPE)
      YYI=YI(MTYPE)
      ZZI=ZI(MTYPE)
      XXI=YYI + ZZI
      GO TO 569
C
  562 IF (ISECT-1) 561,561,565
C
C     RECTANGULAR  CROSS-SECTION
C
  561 XAREA=PROP(3,MTYPE)*PROP(4,MTYPE)
      ZZI=(XAREA*PROP(3,MTYPE)**2)/12.
      YYI=(XAREA*PROP(4,MTYPE)**2)/12.
      XXI=YYI + ZZI
      GO TO 569
C
C     PIPE CROSS-SECTION
C
  565 XAREA=PI*(PROP(3,MTYPE)**2 - PROP(4,MTYPE)**2)/4.
      YYI=XAREA*(PROP(3,MTYPE)**2 + PROP(4,MTYPE)**2)/16.
      ZZI=YYI
      XXI=YYI + ZZI
C
  569 CALL MASS (AS,XLT,XXI,YYI,ZZI,XAREA,DEN(MTYPE))
C
      IF (NMOMNT.EQ.0) GO TO 567
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 567
      CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
  567 CONTINUE
C
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
C
      K= 0
      DO 675 I= 1,12
      DO 675 J= I,12
      K= K+1
  675 S(K) = AS(I,J)
C
      IF (NEGSKS.EQ.0) GO TO 680
      IF (ISKEW(1,N).LT.0) GO TO 680
      ILSK(1)=ISKEW(1,N)
      ILSK(2)=ILSK(1)
      ILSK(3)=ISKEW(2,N)
      ILSK(4)=ILSK(3)
      CALL ATKA (RSDCOS,S,ILSK,4,3)
  680 CONTINUE
C
      CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
C
  670 CONTINUE
      RETURN
C
C
C     A S S E M B L E    F I N A L   N O N L I N E A R
C     S T I F F N E S S    M A T R I X
C
C
  700 ISTRES=-1
      DO 710 N=1,NUME
C
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE .EQ. 1) IELCPL=IELCPL + 1
      IF (ICODE.EQ.1) GO TO 710
C
      ISKEL=0
      IF (NEGSKS.EQ.0) GO TO 685
      IF (ISKEW(1,N).LT.0) GO TO 685
      ISKEL=1
      ILSK(1)=ISKEW(1,N)
      ILSK(2)=ILSK(1)
      ILSK(3)=ISKEW(2,N)
      ILSK(4)=ILSK(3)
      ILTK(1)=ISKEW(1,N)
      ILTK(2)=0
      ILTK(3)=ISKEW(2,N)
      ILTK(4)=0
      ILRK(1)=0
      ILRK(2)=ISKEW(1,N)
      ILRK(3)=0
      ILRK(4)=ISKEW(2,N)
  685 CONTINUE
C
      IF (IDEATH.EQ.0) GO TO 692
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 690
      IF (TIME.LT.ETIM) GO TO 710
      IF (ETIMV(N).GE.0.D0) GO TO 692
      ETIMV(N)=ETIM
      DO 695 L=1,12
      I=LM(L,N)
      IF (I.EQ.0) GO TO 695
      IF (I.LT.0) I=NEQ - I
      EDISP(L,N)=X(I)
  695 CONTINUE
      IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,EDISP(1,N),ILTK,4,3,1)
      GO TO 692
  690 IF (TIME.GT.ETIM) GO TO 710
C
  692 MTYPE=MATP(N)
      EY=PROP(1,MTYPE)
      XNU=PROP(2,MTYPE)
      FAC=EY/(1. - XNU - 2.*XNU*XNU)
      PFAC=EY/(2.*(1. + XNU))
C
      DO 735 I=1,16
      DISP(I)=0.0
  735 RE(I)=0.0
C
  718 DO 720 I=1,ND
      IP=LM(I,N)
      IF (IP.EQ.0) GO TO 720
      IF (IP.LT.0) IP=NEQ - IP
      DISP(I)=X(IP)
  720 CONTINUE
C
C     ROTATE TRANSLATIONS TO GLOBAL SYSTEM
C
      IF (ISKEL.EQ.0) GO TO 770
      CALL DIRCOS (RSDCOS,DISP,ILTK,4,3,1)
  770 CONTINUE
C
      MTYPE=MATP(N)
C
C
      IF (IDEATH.NE.1) GO TO 728
      DO 772 I=1,ND
  772 DISP(I)=DISP(I) - EDISP(I,N)
      DO 727 L=1,3
      DXYZ(L)=XYZ(L,N) + EDISP(L,N)
  727 DXYZ(L+3)=XYZ(L+3,N) + EDISP(L+6,N)
      CALL LENGTH(XLT,DXYZ)
      GO TO 730
  728 CALL LENGTH (XLT,XYZ(1,N))
  730 ITONLY=1
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
C
C     CALCULATE NEW LOCAL AXIS FOR U.L. FORMULATION
C
  712 ITONLY=3
      IF (INDNL.EQ.2)
     1 CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
      DO 762 I=1,12
      DISP(I)=DISP(I) - PDISP(I,N)
      IF (ICOUNT.NE.3 .AND. ITONLY.NE.5)
     1 PDISP(I,N)=PDISP(I,N) + DISP(I)
  762 CONTINUE
C
C     ROTATE INCREMENTAL ROTATIONS TO GLOBAL SYSTEM
C
      IF (ISKEL.EQ.0) GO TO 780
      CALL DIRCOS (RSDCOS,DISP,ILRK,4,3,1)
  780 CONTINUE
      IF (INDNL.LT.2) XLN=XLT
C
C     TRANSER THE GLOBAL DISPLACEMENT TO THE LOCAL COORDINATE
C
      DO 722 I=1,10,3
      DO 722 J=1,3
      IJ=I + J - 1
      TEMP=0.
      DO 723 K=1,3
      IK=I + K - 1
  723 TEMP=TEMP + T(J,K)*DISP(IK)
  722 XM(IJ)=TEMP
      DO 725 I=1,12
  725 DISP(I)=XM(I)
      IF (NMOMNT.EQ.0) GO TO 755
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 755
      NDRL=0
      DO 756 I=1,6
      IF (IMOMNT(I,IELRE).EQ.0) GO TO 757
  756 NDRL=NDRL + 1
  757 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,3)
  755 CONTINUE
C
      CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
     1            ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
C
      DO 732 I=1,ND
  732 XM(I)=RE(I)
      DO 733 I=1,10,3
      DO 733 J=1,3
      TEMP=0.0
      IJ=I + J - 1
      DO 734 K=1,3
      IK=I + K - 1
  734 TEMP=TEMP + T(K,J)*XM(IK)
  733 RE(IJ)=TEMP
  714 MADR=N3
      IF (ICOUNT.EQ.3) MADR=N5
      IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,RE,ILSK,4,3,2)
      CALL ADDBAN (A(MADR),A(N1),S,RE,LM(1,N),ND,2)
C
      IF (ICOUNT-2) 740,740,710
  740 IF (IREF) 710,742,710
  742 K=0
C
      IF (NMOMNT.EQ.0) GO TO 750
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 750
      NDRL=0
      DO 751 I=1,6
      IF (IMOMNT(I,IELRE).EQ.0) GO TO 752
  751 NDRL=NDRL + 1
  752 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,2)
  750 CONTINUE
C
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),2)
      DO 745 I=1,ND
      DO 745 J=I,ND
      K=K + 1
  745 S(K)=AS(I,J)
      IF (ISKEL.EQ.1) CALL ATKA (RSDCOS,S,ILSK,4,3)
      CALL ADDBAN (A(N4),A(N1),S,RE,LM(1,N),ND,1)
  710 CONTINUE
      IF (IELCPL.EQ.NUME) IELCPL=-1
      RETURN
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 802
      RECLAB=RECLB6
      WRITE (LU1) RECLAB,NG,(NPAR(I),I=1,20),KSTEP,TIME,NEGL,NSUB
C
C***  DATA PORTHOLE (END)
C
  802 IF (INDNL.GT.0) GO TO 850
C
C     GEOMETRICALLY AND  MATERIALLY LINEAR STRESS CALCULATION
C
      IPRNT = 0
      ITONLY=1
      DO 830 N= 1,NUME
      IPST= IPS(N)
      IF (IPST.EQ.0) GO TO 830
      DO 806 I=1,12
  806 STR(I)=0.
      IF (IPRI.NE.0) GO TO 810
      IPRNT=IPRNT + 1
      IF (IPRNT.NE.1) GO TO 810
      WRITE(6,2006) NG
  810 MTYPE=MATP(N)
      CALL LENGTH (XLT,XYZ(1,N))
      CALL STIFF (AS,XLT,E(MTYPE),G(MTYPE),XI(MTYPE),YI(MTYPE),
     1            ZI(MTYPE),AREA(1,MTYPE))
C
      IF (NMOMNT.EQ.0) GO TO 815
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 815
      CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
C
  815 CONTINUE
C
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
      DO 820 I=1,ND
      DISP(I)=0.
      IP=LM(I,N)
      IF (IP.EQ.0) GO TO 820
      IF (IP.LT.0) IP=NEQ - IP
      DISP(I)=X(IP)
  820 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 822
      IF (ISKEW(1,N).LT.0) GO TO 822
      ILSK(1)=ISKEW(1,N)
      ILSK(2)=ILSK(1)
      ILSK(3)=ISKEW(2,N)
      ILSK(4)=ILSK(3)
      CALL DIRCOS (RSDCOS,DISP,ILSK,4,3,1)
  822 CONTINUE
C
      DO 840 I=1,10,3
      DO 840 J=1,3
      IJ=I+J-1
      TEMP=0.
      DO 835 K=1,3
      IK=I+K-1
  835 TEMP=TEMP + T(J,K)*DISP(IK)
  840 XM(IJ)=TEMP
C
      DO 824 I=1,12
      TEMP=0.
      DO 826 J=1,12
  826 TEMP=TEMP + AS(I,J)*XM(J)
  824 STR(I)=TEMP
      IF (IPRI.NE.0) GO TO 825
      WRITE(6,2007) N,(STR(I) ,I=1,6)
      WRITE(6,2008)  (STR(J) ,J=7,12)
C
C***  DATA PORTHOLE (START)
C
  825 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 830
      RECLAB=RECLB7
      WRITE(LU1) RECLAB,N,(STR(I),I=1,12)
C
C***  DATA PORTHOLE (END)
C
  830 CONTINUE
      RETURN
C
C
C     GEOMETRICALLY  OR/AND  MATERIALLY  NONLINEAR  STRESS  CALCULATION
C
  850 IPRNT=0
      DO 855 N=1,NUME
C
      ISKEL=0
      IF (NEGSKS.EQ.0) GO TO 876
      IF (ISKEW(1,N).LT.0) GO TO 876
      ISKEL=1
      ILTK(1)=ISKEW(1,N)
      ILTK(2)=0
      ILTK(3)=ISKEW(2,N)
      ILTK(4)=0
      ILRK(1)=0
      ILRK(2)=ISKEW(1,N)
      ILRK(3)=0
      ILRK(4)=ISKEW(2,N)
  876 CONTINUE
C
      IF (IDEATH.EQ.0) GO TO 854
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 853
      IF (TIME.LT.ETIM) GO TO 855
      GO TO 854
  853 IF (TIME.GT.ETIM) GO TO 855
C
  854 IPST=IPS(N)
      IF (IPST.EQ.0) GO TO 855
      IPRNT=IPRNT + 1
      IF (IPRNT.NE.1 .OR.  IPRI.NE.0) GO TO 894
      IF (NTABLE.EQ.-1) WRITE (6,2006) NG
      IF (NTABLE.GE.0) WRITE (6,2025) NG
  894 MTYPE = MATP(N)
      EY=PROP(1,MTYPE)
      XNU=PROP(2,MTYPE)
      FAC=EY/(1. - XNU -2.*XNU*XNU)
      PFAC=EY/(2.*(1. + XNU))
      DO 845 I=13,16
  845 DISP(I)=0.0
      DO 856 I=1,ND
      DISP(I)=0.
      IP=LM(I,N)
      IF (IP.EQ.0) GO TO 856
      IF (IP.LT.0) IP=NEQ - IP
      DISP(I)=X(IP)
  856 CONTINUE
      IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,DISP,ILTK,4,3,1)
      IF (IDEATH.NE.1) GO TO 880
      DO 886 I=1,ND
  886 DISP(I)=DISP(I) - EDISP(I,N)
      DO 858 L=1,3
      DXYZ(L)=XYZ(L,N) + EDISP(L,N)
  858 DXYZ(L+3)=XYZ(L+3,N) + EDISP(L+6,N)
      CALL LENGTH (XLT,DXYZ)
      GO TO 881
  880 CALL LENGTH (XLT,XYZ(1,N))
  881 CONTINUE
C
C     TRANSFER  THE  GLOBAL  DISPLACEMENTS  TO  LOCAL  COORDINATES
C
      ITONLY=1
      CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
C
C     CALCULATE NEW LOCAL AXIS FOR U.L. FORMULATION
C
      ITONLY=3
      IF (INDNL.EQ.2)
     1 CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
      DO 863 I=1,ND
  863 DISP(I)=DISP(I) - PDISP(I,N)
      IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,DISP,ILRK,4,3,1)
      IF (INDNL.LT.2) XLN=XLT
C
      DO 870 I=1,10,3
      DO 870 J=1,3
      IJ=I + J - 1
      TEMP=0.
      DO 871 K=1,3
      IK=I + K - 1
  871 TEMP=TEMP + T(J,K)*DISP(IK)
  870 XM(IJ)=TEMP
      DO 873 I=1,12
  873 DISP(I)=XM(I)
      IF (NMOMNT.EQ.0) GO TO 890
      IELRE=IELRET(N)
      IF (IELRE.EQ.0) GO TO 890
      NDRL=0
      DO 878 I=1,6
      IF (IMOMNT(I,IELRE).EQ.0) GO TO 879
  878 NDRL=NDRL + 1
  879 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,3)
C
C
  890 ISTRES=0
      IF (NTABLE) 859,862,865
C
C     NTABLE.EQ.-1       NODAL FORCE CALCULATION
C     NTABLE.EQ. 0       STRESS CALCULATION AT ALL INTEGRATION POINTS
C
  859 DO 895 IJ=1,16
  895 RE(IJ) = 0.0
  862 CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
     1             ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
      IF (NTABLE.EQ.0) GO TO 891
      IF (IPRI.NE.0) GO TO 892
      WRITE (6,2007) N, ( RE(IN),IN=1,6 )
      WRITE (6,2008)     ( RE(IN),IN=7,12 )
C
C***  DATA PORTHOLE (START)
C
  892 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 893
      RECLAB=RECLB7
      WRITE(LU1) RECLAB,N,(RE(IN),IN=1,12)
C
C***  DATA PORTHOLE (END)
C
  893 CONTINUE
      GO TO 855
C
  891 IST = 1- NST
      IF (INDNL.EQ.2) IST=IST + 1
      LNC=0
      DO 860 I1=1,INTX
      DO 860 I3=1,INTZ
      DO 860 I2=1,INTY
      LNC=LNC+1
      IST=IST + NST
      J=1
      IF (MODEL.EQ.2) GO TO 910
C
      L1=IST
      L2=IST + 2
      IF (IPRI.NE.0) GO TO 920
C
      IF (LNC.LE.1) WRITE (6,2026) N
      WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
      GO TO 920
C
  910 IST1=IST + 1
      IST2=IST1 + 1
      IST3=IST2 + 3
      IST4=IST3 + 3
      L1=IST2
      L2=IST2 + 2
      L3=IST3
      L4=IST3 + 2
      L5=IST4
      L6=IST4 + 2
      IF (WA(IST,N).GT.0.0) J=2
      IF (IPRI.NE.0) GO TO 920
C
      IF (LNC.LE.1) WRITE (6,2026) N
      WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
      IF (IPST.LT.0) WRITE (6,2028) (WA(LK,N),LK=L3,L4)
      IF (IPST.LT.0) WRITE (6,2029) (WA(LK,N),LK=L5,L6)
      YLDOUT=DABS(WA(IST,N))
      WRITE (6,2031) YLDOUT,WA(IST1,N)
C
C***  DATA PORTHOLE (START)
C
  920 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 860
      RECLAB=RECLB7
      WRITE (LU1) RECLAB,N,I1,I2,I3,(WA(LK,N),LK=L1,L2)
C
C***  DATA PORTHOLE (END)
C
  860 CONTINUE
C
      IF (INDNL.EQ.2) WA(1,N)=EPS
      GO TO 855
C
C     STRESS CALCULATION AT SELECTED INTEGRATION POINTS
C
  865 ISTRES=1
      LNC=0
      L=IABS(IPST)
      IF (L.GT.NTABLE) L=NTABLE
      DO 867 K=1,JTABLE
      M=ITABLE(L,K)
      IF (M) 855,855,868
  868 I1=M/100
      II=M - I1*100
      I2=II/10
      I3=II - I2*10
      LNC=LNC+1
      IST=NST*(I2 - 1 + INTY*((I3 - 1) + INTZ*(I1 - 1))) + 1
      IF (INDNL.EQ.2) IST=IST + 1
      ISTRES=IST
      CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
     1             ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
      J=1
      IF (MODEL.EQ.2) GO TO 930
C
      L1=IST
      L2=IST + 2
      IF (IPRI.NE.0) GO TO 940
C
      IF (LNC.LE.1) WRITE (6,2026) N
      WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
      GO TO 940
C
  930 IST1=IST + 1
      IST2=IST1 + 1
      IST3=IST2 + 3
      IST4=IST3 + 3
      L1=IST2
      L2=IST2 + 2
      L3=IST3
      L4=IST3 + 2
      L5=IST4
      L6=IST4 + 2
      IF (WA(IST,N).GT.0.0) J=2
      IF (IPRI.NE.0) GO TO 940
C
      IF (LNC.LE.1) WRITE (6,2026) N
      WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
      IF (IPST.LT.0) WRITE (6,2028) (WA(LK,N),LK=L3,L4)
      IF (IPST.LT.0) WRITE (6,2029) (WA(LK,N),LK=L5,L6)
      YLDOUT=DABS(WA(IST,N))
      WRITE (6,2031) YLDOUT,WA(IST1,N)
C
C***  DATA PORTHOLE (START)
C
  940 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 867
      RECLAB=RECLB7
      WRITE (LU1) RECLAB,N,I1,I2,I3,(WA(LK,N),LK=L1,L2)
C
C***  DATA PORTHOLE (END)
C
  867 CONTINUE
      IF (INDNL.EQ.2) WA(1,N)=EPS
C
  855 CONTINUE
      RETURN
C
 1000 FORMAT (I5,3F10.0)
 1001 FORMAT (6F10.0)
 1002 FORMAT (7I5,F10.0,2I5)
 1009 FORMAT (16I5)
 1010 FORMAT (2I5,F10.0)
 1011 FORMAT (8F10.0)
 1050 FORMAT (6I5)
C
C
 2002 FORMAT (//,40H S E C T I O N   D E F I N I T I O N          //,
     1            2X,4HTYPE,11X,1HE,10X,3HXNU,12X,3HDEN)
 2003 FORMAT (/I5,5X,3E15.7)
 2005 FORMAT (/7I6,E10.3,2I6)
 2006 FORMAT(1H1,  76H S T R E S S   C A L C U L A T I O N S   F O R   E
     1 L E M E N T   G R O U P  ,I5,10H  (BEAMS) //,4X,
     2        7HELEMENT,7X,7HR-FORCE,8X,7HS-FORCE,8X,7HT-FORCE,
     3        12X,8HR-MOMENT,7X,8HS-MOMENT,7X,8HT-MOMENT/)
 2007 FORMAT (4X,I5,3X,1HI,2X,3E15.6,5X,3E15.6)
 2008 FORMAT (12X,1HJ,2X,3E15.6,5X,3E15.6/)
 2009 FORMAT(/,I5,5X,3E15.7,5X,3E15.7)
 2010 FORMAT (////,2X,4HTYPE,8X,9HR-INERTIA,6X,9HS-INERTIA,6X,
     1        9HT-INERTIA,15X,
     2        4HAREA,5X,13HSHEAR AREA(S),3X,13HSHEAR AREA(T))
 2011 FORMAT ( //,40H E L E M E N T   I N F O R M A T I O N         ///,
     1          43H     N     II    JJ    KK  TYPE   IPS    KG,4X,
     2          5HETIME,2X,5HIELRE,1X,6HINTLOC,3X,17HINTEGRATION POINT,
     3        13X,19HGLOBAL  COORDINATES/68X,17H  R      S      T, 1X,
     3          9X,1HX,12X,1HY,12X,1HZ)
 2310 FORMAT (69X,I2,2(5X,I2),4X,E11.4,2(2X,E11.4))
 3010 FORMAT (////14H *** STOP ***   //
     1  16H ELEMENT GROUP =,I5/
     2  36H ERROR IN NODE NUMBERING FOR ELEMENT,I5//)
 3011 FORMAT (////14H *** STOP ***   //
     1  16H ELEMENT GROUP =,I5/
     2  46H ERROR IN AUXILIARY NODE NUMBERING FOR ELEMENT, I5//)
 3013 FORMAT (69X,42H INTEGRATION POINT PRINTING NOT APPLICABLE)
 2020 FORMAT (///,40H S E C T I O N   D E F I N I T I O N         ///,
     1        5X,4HTYPE,5X,6HISHEAR,10X,3HDEN/)
 2021 FORMAT (4X,I5,5X,I5,3X,E15.4)
 2022 FORMAT (//,40H S E C T I O N   P R O P E R T Y              //,
     1       2X,4HTYPE,6X,9HPROP(1)=E,4X,11HPROP(2)=XNU,5X,10HPROP(3)=DO
     2,      5X,10HPROP(4)=DI,3X,12HPROP(5)=SIGY,5X,10HPROP(6)=ET/)
 2023 FORMAT (I5,6E15.4)
 2025 FORMAT(1H1,  76H S T R E S S   C A L C U L A T I O N S   F O R   E
     1 L E M E N T   G R O U P  ,I5,10H  (BEAMS) //,
     2        1X,7HELEMENT,2X,8HLOCATION,2X,6HSTRESS,6X,
     3        13HSTRESS/STRAIN,8X,2HRR,14X,2HRS,14X,2HRT,/,11X,
     4        7HR  S  T,2X,5HSTATE,7X,10HCOMPONENTS)
 2026 FORMAT (/,1X,I5)
 2027 FORMAT (10X,3(I2,1X),1X,A8,4X,6HSTRESS,9X,3(E14.6,2X))
 2028 FORMAT (32X,12HSTRAIN-TOTAL,3X,3(E14.6,2X))
 2029 FORMAT (37X,7HPLASTIC,3X,3(E14.6,2X))
 2030 FORMAT (///,40H S E C T I O N   P R O P E R T Y             ///,
     1       2X,4HTYPE,6X,9HPROP(1)=E,4X,11HPROP(2)=XNU,5X,10HPROP(3)=DO
     2,      5X,10HPROP(4)=DI/)
 2031 FORMAT (32X,15HYIELD STRESS = ,E14.6,2X,
     1        29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/)
 2100 FORMAT (//,1X,30HS E C T I O N  P R O P E R T Y,//,2X,4HTYPE,4X,
     1        11HPROP(1) = E,4X,13HPROP(2) = XNU,3X,12HPROP(3) = DO,
     2        4X,12HPROP(4) = DI,8X,
     3        36HPIECEWISE-LINEAR STRESS-STRAIN CURVE,/,77X,6HSTRESS,
     4        10X,6HSTRAIN,11X,2HET)
 2110 FORMAT (//,1X,I5,6(2X,E14.6))
 2120 FORMAT (70X,3(2X,E14.6))
 2200 FORMAT (//,17H   STRESS TABLE (,I3,3H  )/)
 2201 FORMAT (10X,16I5)
 2210 FORMAT (//,45H M O M E N T  R E L E A S E  T A B L E S        //,
     1        5X,5HTABLE//)
 2220 FORMAT (5X,7I5)
 2400 FORMAT (///16H ELEMENT GROUP =,I2, 15H  (BEAM / BMEL)/
     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,15H  (BEAM / BMEL)/
     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
 3000 FORMAT (1H1,///47H *** ERROR IN BEAM MATERIAL PROPERTY INPUT DATA/
     1        9H SET NO =,I5,10H  ISHEAR =,I5//)
 3401 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
     2          19H ELEMENT GROUP NO =,I5/
     3          27H MATERIAL PROPERTY SET NO =,I5/
     1  58H INNER DIAMETER OF PIPE SECTION IS GREATER OR EQUAL TO      ,
     2  16H OUTER DIAMETER   //)
 3402 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
     2          19H ELEMENT GROUP NO =,I5/
     3          27H MATERIAL PROPERTY SET NO =,I5/
     4  38H ZERO OR NEGATIVE INITIAL YIELD STRESS  //)
 3403 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
     2          19H ELEMENT GROUP NO =,I5/
     3          27H MATERIAL PROPERTY SET NO =,I5/
     4  60H HARDENING MODULUS (ET) GREATER OR EQUAL TO  YOUNG S MODULUS,
     5  30H  (E) IS NOT ALLOWED.           //)
 3404 FORMAT (//45H INPUT ERROR IN MATERIAL/SECTION PROPERTIES     //
     1          15H *** STOP ***     //)
 3500 FORMAT(///23H INPUT ERROR **********/
     1          19H SUBSTRUCTURE  NO =,I3/
     2          19H ELEMENT GROUP NO =,I3/
     3          31H FIRST ELEMENT NUMBER MUST BE 1)
C
      END
