home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e001 / 1.ddi / TMP / ADINA31.FOR < prev    next >
Encoding:
Text File  |  1991-01-07  |  201.3 KB  |  7,562 lines
  1. C *CDC* *DECK CMOD3D
  2. C *UNI* )FOR,IS  N.CMOD3D, R.CMOD3D
  3.       SUBROUTINE CMOD3D (NEL,EKK,RKLD,RKUN,GLD,SP33,SIG,EPS,EVMAX,
  4.      1                  EVGRAV,PGRAV,DCA,CRKSTR,STRESS,STRAIN,C,IPT,
  5.      2                   NODS,TEMPV1,TEMPV2,XYZ,NOD9,WA)
  6. C
  7. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  8. C .                                                                   .
  9. C .                                                                   .
  10. C .   MODEL  4       CDMOD WITH OR WITHOUT TENSION CUT-OFF            .
  11. C .      EKK       STRAIN ABCISSAE                                    .
  12. C .      RKLD      LOADING BULK MODULUS                               .
  13. C .      RKUN      UNLOADING BULK MODULUS                             .
  14. C .      GLD       LOADING SHEAR MODULUS                              .
  15. C .      EVMAX     MAXIMUM VOLUMETRIC STRAIN EVER REACHED (COMP +)    .
  16. C .      EVGRAV    VOLUMETRIC STRAIN DUE TO GROUND PRESSURE (COMP + ) .
  17. C .      PGRAV     GROUND PRESSURE (COMP +)                           .
  18. C .                                                                   .
  19. C .   MODEL  5       CONCRETE STRUCTURE MODEL                         .
  20. C .      EKK       YOUNG@S MODULUS AND POISSON@S RATIO                .
  21. C .      RKLD,RKUN,GLD,SP33  COMPRESSIVE FAILURE CURVES DATA          .
  22. C .      EVMAX     MAXIMUM VALUE OF LOADING FUNCTION EVER REACHED     .
  23. C .      EVGRAV    INTERPOLATED TEMPERATURE OF PREVIOUS TIME STEP     .
  24. C .      PGRAV     INDICATOR  SET TO 100. IF CRUSHING FAILURE OCCURS  .
  25. C .                                                                   .
  26. C .      SIG       STRESSES FROM THE PREVIOUS TIME STEP               .
  27. C .      EPS       STRAINS  FROM THE PREVIOUS TIME STEP               .
  28. C .      DCA       ORIENTATION OF CRACK
  29. C .      CRKSTR    STRAINS AT WHICH CRACKS OPENED                     .
  30. C .                                                                   .
  31. C .      STRESS    CURRENT STRESSES                                   .
  32. C .      STRAIN    CURRENT STRAINS                                    .
  33. C .      C         CURRENT ELASTICITY MODULUS MATRIX                  .
  34. C .      IPT       INTEGRATION POINT INDICATOR                        .
  35. C .                                                                   .
  36. C .                                                                   .
  37. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  38. C
  39. C
  40.       IMPLICIT REAL*8 (A-H,O-Z)
  41. C
  42.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  43.      1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  44.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  45.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  46.       COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
  47.      1               RAM5,RBM5,RCM5,ICRACK,MOD45
  48.       COMMON /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
  49.      1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
  50.       COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),F1,F2,F3
  51. C
  52.       DIMENSION EKK(1),RKLD(1),RKUN(1),GLD(1),SIG(6),EPS(6),DCA(4),
  53.      1          CRKSTR(3),STRESS(6),STRAIN(6),C(6,6),RLMN(3,3),NODS(1),
  54.      2          TEMPV1(1),TEMPV2(1),XYZ(1),NOD9(1),WA(1),DUMWA(22),
  55.      3          SP33(1)
  56.       EQUIVALENCE (SIGP(1),P1), (SIGP(2),P2), (SIGP(3),P3)
  57. C
  58.       EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ),(NPAR(17),NCON)
  59.      1           ,(NPAR(15),MODEL),(NPAR(19),ITHERM),(NPAR(3),INDNL)
  60. C
  61.       IF (IUPDT .EQ. 0) GO TO 3
  62.       DO 1 I=1,22
  63.     1 DUMWA(I)=WA(I)
  64. C
  65.     3 IF (MODEL.EQ.4) FALSTR = PGRAV
  66.       NPT=NINT*NINT*NINTZ
  67.       IPOINT=6
  68.       MOD45=1
  69.       NUMCRK=0
  70.       ANGPRI=100.
  71.       ILFSET=0
  72. C
  73. C
  74. C        1. CALCULATE STRESS AND STRAIN DEVIATORS
  75. C           OF THE PREVIOUS TIME STEP
  76. C
  77. C
  78.       TMM=(SIG(1)+SIG(2)+SIG(3))/3.
  79.       T11=SIG(1) - TMM
  80.       T22=SIG(2) - TMM
  81.       T33=SIG(3) - TMM
  82.       T12=SIG(4)
  83.       T13=SIG(5)
  84.       T23=SIG(6)
  85. C
  86.       EVV=-(EPS(1)+EPS(2)+EPS(3))
  87.       EMM=-EVV/3.
  88.       E11=EPS(1) - EMM
  89.       E22=EPS(2) - EMM
  90.       E33=EPS(3) - EMM
  91.       E12=EPS(4)
  92.       E13=EPS(5)
  93.       E23=EPS(6)
  94. C
  95.       SBAR=((SIG(1)-SIG(2))**2+(SIG(2)-SIG(3))**2+(SIG(3)-SIG(1))**2)/6.
  96.       SBAR=SBAR + SIG(4)**2 + SIG(5)**2 + SIG(6)**2
  97.       IF (MODEL.EQ.5) EVV=DSQRT(SBAR) + 3.*ALFA*TMM
  98. C
  99. C
  100. C        2. CALCULATE PARAMETERS BASED ON STRESSES AND STRAINS
  101. C           OF THE PREVIOUS UPDATE
  102. C
  103. C
  104.       IKAS=1
  105.       IF (DABS(EVV-EVMAX).GT.DABS(EVMAX)*1.D-8) IKAS=-1
  106.       IF (MODEL.EQ.4) EVTOT=EVMAX + EVGRAV
  107.       IK=1
  108.       ITEM=1
  109. C
  110. C **  OBTAIN MATERIAL PROPERTIES FOR CONCRETE (MODEL=5)  * * * *
  111. C
  112.     5 IF (MODEL.EQ.4) GO TO 10
  113. C
  114. C     UNLOADING/RELOADING - USE INITIAL YOUNGS MODULUS, ISOTROPIC LAW
  115. C
  116.       E=EKK(1)
  117.       VNU=EKK(2)
  118.       TMPOLD=EVGRAV
  119. C
  120. C     CHECK WHETEHER ALREADY COMPLETELY FAILED IN COMPRESSION
  121. C
  122.       IF (PGRAV.NE.100.) GO TO 12
  123.       IKAS=1
  124.       E=E*STIFAC
  125.       SIGCP=CRKSTR(1)
  126.       EPSCP=CRKSTR(2)
  127.       IF (EVV.EQ.0.) GO TO 45
  128.       E=EKK(1)
  129. C
  130. C     LOADING
  131. C
  132.    12 IF (ITEM.NE.1) GO TO 7
  133.       IF (IKAS.GT.0 .AND. (DCA(4).GT.10. .OR. PGRAV.EQ.100.))
  134.      1 CALL PRNCP3 (SIG,EPS,RLMN,RKLD,RKUN,GLD,SP33,TEP,PGRAV,MODEL,1)
  135.       IF (DCA(4).LE.1. .AND. PGRAV.NE.100.)
  136.      1 CALL CRAK3D (SIG,EPS,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
  137.      2              RLMN,TEP,NUMCRK,MODEL,1)
  138. C
  139. C     ROTATE INCREMENTAL STRAINS TO PREVIOUS TIME PRINCIPAL/CRACK PLANES
  140. C
  141.       IF (IKAS.GT.0 .AND. (DCA(4).GT.10. .OR. PGRAV.EQ.100.))
  142.      1 CALL PRNCP3 (SIG,STRAIN,RLMN,RKLD,RKUN,GLD,SP33,EP,PGRAV,MODEL,2)
  143.       IF (DCA(4).LE.1. .AND. PGRAV.NE.100.)
  144.      1 CALL CRAK3D (SIG,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
  145.      2              RLMN,EP,NUMCRK,MODEL,2)
  146.       IF (IKAS.LT.0) GO TO 45
  147. C
  148. C     NUMERICAL INTEGRATION TO COMPUTE TANGENT MODULI
  149. C
  150.       NUMINT=3
  151.     7 IF (ITEM.EQ.2) NUMINT=1
  152.       DENM=DABS(P1) + DABS(P2) + DABS(P3)
  153.       IF (DENM.LE.0.00001*SIGMAT) GO TO 45
  154. C
  155.       RP=EPSU/EPSC
  156.       ES=SIGCP/EPSCP
  157.       EU=(SIGMAU*SIGCP/SIGMAC)/(EPSU*EPSCP/EPSC)
  158.       RAM5=EKK(1)/EU + (RP - 2.)*RP*RP*EKK(1)/ES - (2.*RP+1)*(RP-1.)**2
  159.       RAM5=RAM5/(RP*(RP - 1.)**2)
  160.       RBM5=2.*EKK(1)/ES - 3. - 2.*RAM5
  161.       RCM5=2. - EKK(1)/ES + RAM5
  162. C
  163.       NUMSIG=1
  164.       IF (PGRAV.EQ.100.) NUMSIG=3
  165.       DO 6 I=NUMSIG,3
  166.       YP(I)=E
  167.       IF (SIGP(I).GE.0.001*SIGCP) GO TO 6
  168. C
  169.       YP(I)=0.
  170.       DO 4 L=1,NUMINT
  171.       E1=XG(L,NUMINT)
  172.       DE=TEP(I) + (1 + E1)*(EP(I) - TEP(I))/2.
  173.       DE=DE/EPSCP
  174.       TY=E
  175.       IF (DE.LE.0.) GO TO 4
  176.       TY=E*(1. - RBM5*DE*DE - 2.*RCM5*DE**3)
  177.       TY=TY/(1. + RAM5*DE + RBM5*DE*DE + RCM5*DE**3)**2
  178.     4 YP(I)=YP(I) + 0.5*WGT(L,NUMINT)*TY
  179.     6 CONTINUE
  180. C
  181. C     ALREADY FAILED IN COMPRESSION
  182. C
  183.       IF (PGRAV.NE.100.) GO TO 8
  184.       E=YP(3)
  185.       IF (E.GT.0.) E=0.
  186.       GO TO 45
  187. C
  188. C     EQUIVALENT ISOTROPIC LAW
  189. C
  190.     8 MOD45=1
  191.       DE=RKAPA*SIGCP
  192.       IF (P1.LT.DE .OR. P2.LT.DE .OR. P3.LT.DE) MOD45=2
  193.       E=(DABS(P1)*YP(1) + DABS(P2)*YP(2) + DABS(P3)*YP(3))/DENM
  194.       IF (MOD45.EQ.1) GO TO 45
  195. C
  196. C     ORTHOTROPIC STRESS-STRAIN LAW
  197. C
  198.       E12=E
  199.       DENM=DABS(P1) + DABS(P2)
  200.       IF (DENM.NE.0.) E12=(DABS(P1)*YP(1) + DABS(P2)*YP(2))/DENM
  201.       E13=E
  202.       DENM=DABS(P1) + DABS(P3)
  203.       IF (DENM.NE.0.) E13=(DABS(P1)*YP(1) + DABS(P3)*YP(3))/DENM
  204.       E23=E
  205.       DENM=DABS(P2) + DABS(P3)
  206.       IF (DENM.NE.0.) E23=(DABS(P2)*YP(2) + DABS(P3)*YP(3))/DENM
  207.       GO TO 45
  208. C
  209. C **  OBTAIN MATERIAL PROPERTIES FOR CDMODEL (MODEL=4)   * * * *
  210. C
  211.    10 DO 15 L=IK,IPOINT
  212.       J=L
  213.       IF (EVTOT.LT.EKK(J)) GO TO 28
  214.    15 CONTINUE
  215.       WRITE(6,2000) EVTOT,NEL,EKK(IPOINT)
  216.       STOP
  217. C
  218.    28 I=J-1
  219. C
  220.       DELEV=EKK(J) - EKK(I)
  221.       DELEI=EVTOT - EKK(I)
  222.       RATIO=DELEI / DELEV
  223. C
  224.       IF (IKAS) 30,35,35
  225. C
  226.    30 RKUNLO=RKUN(I) + RATIO * (RKUN(J) - RKUN(I))
  227.    35 RK =RKLD(I) + RATIO * (RKLD(J) - RKLD(I))
  228.       G    =GLD(I) + RATIO * ( GLD(J) - GLD(I) )
  229. C
  230.       IF (IKAS) 40,45,45
  231. C
  232.    40 G=G * (RKUNLO/RK)
  233.       RK=RKUNLO
  234. C
  235.    45 IF (ITEM.EQ.2) GO TO 100
  236. C
  237. C
  238. C        3. IF CRACKING HAS OCCURRED, USE PARAMETERS CALCULATED IN (2.)
  239. C           WITH CRACKED MODEL TO FIND CURRENT STRESSES BASED ON
  240. C           GIVEN STRAINS
  241. C
  242. C
  243.       IF (MODEL.EQ.5) GO TO 46
  244.       IF (ICRACK.LT.1) GO TO 50
  245.       IF (DCA(4).GT.10.) GO TO 50
  246.       CALL CRAK3D (SIG,EPS,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
  247.      1              RLMN,TEP,NUMCRK,MODEL,1)
  248.       CALL CRAK3D (SIG,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
  249.      1              RLMN,EP,NUMCRK,MODEL,2)
  250.       GO TO 47
  251. C
  252.    46 RK=E/(3.*(1. - 2.*VNU))
  253.       G=E/(2.*(1. + VNU))
  254.       IF (PGRAV.EQ.100.) GO TO 50
  255.       IF (DCA(4).GT.10. .AND. MOD45.EQ.1) GO TO 50
  256. C
  257.    47 CALL DCRAK3 (C,SIG,RLMN,MODEL,NUMCRK,1,1)
  258. C
  259.       DO 57 I=1,3
  260.       K=I + 3
  261.       SIGP(K)=SIGP(K) + C(K,K)*(EP(K) - TEP(K))
  262.       DO 57 J=1,3
  263.    57 SIGP(I)=SIGP(I) + C(I,J)*(EP(J) - TEP(J))
  264. C
  265.       IF (MODEL.EQ.4) GO TO 58
  266.       TEP(1)=EP(1)
  267.       TEP(2)=EP(2)
  268.       TEP(3)=EP(3)
  269.    58 IF (DCA(4).LE.1.0)
  270.      1  CALL CRAK3D (STRESS,STRAIN,DCA,PGRAV,CRKSTR,RKLD,RKUN,GLD,SP33,
  271.      1              RLMN,EP,NUMCRK,MODEL,3)
  272. C
  273.       CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
  274. C
  275.       IF (DCA(4).GT.10.) GO TO 60
  276.       EVI=-(STRAIN(1) + STRAIN(2) + STRAIN(3))
  277.       GO TO 65
  278. C
  279. C
  280. C        4. IF THERE IS NO CRACKING ON PREVIOUS TIME STEP, USE ISOTROPIC
  281. C           LAW WITH PARAMETERS CALCULATED IN (2.) TO FIND CURRENT
  282. C           STRESSES BASED ON GIVEN STRAINS
  283. C
  284. C
  285.    50 EVI=-(STRAIN(1)+STRAIN(2)+STRAIN(3))
  286.       EPSMM=-EVI/3.
  287.       EPS11=STRAIN(1)-EPSMM
  288.       EPS22=STRAIN(2)-EPSMM
  289.       EPS33=STRAIN(3)-EPSMM
  290.       EPS12=STRAIN(4)
  291.       EPS13=STRAIN(5)
  292.       EPS23=STRAIN(6)
  293. C
  294.       PEE=3.*RK*(EPSMM - EMM) + TMM
  295. C
  296.       S11=2.*G*(EPS11-E11)+T11
  297.       S22=2.*G*(EPS22-E22)+T22
  298.       S33=2.*G*(EPS33-E33)+T33
  299.       S12=   G*(EPS12-E12)+T12
  300.       S13=   G*(EPS13-E13)+T13
  301.       S23=   G*(EPS23-E23)+T23
  302. C
  303.       STRESS(1)=S11+PEE
  304.       STRESS(2)=S22+PEE
  305.       STRESS(3)=S33+PEE
  306.       STRESS(4)=S12
  307.       STRESS(5)=S13
  308.       STRESS(6)=S23
  309. C
  310. C
  311. C        5. DETERMINE WHETHER CURRENT STRESSES HAVE CAUSED CRACKING
  312. C           OR CRUSHING TO OCCUR
  313. C
  314. C
  315.    60 CALL PRNCP3 (STRESS,STRAIN,RLMN,RKLD,RKUN,GLD,SP33,EP,PGRAV,
  316.      1             MODEL,1)
  317.       IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 65
  318. C
  319. C     CHECK FOR COMPLETE STRESS RELEASE IF CONCRETE HAS ALREADY CRUSHED
  320. C
  321.       IF (MODEL.NE.5) GO TO 59
  322.       TEP(1)=EP(1)
  323.       TEP(2)=EP(2)
  324.       TEP(3)=EP(3)
  325.       IF (PGRAV.NE.100.) GO TO 59
  326.       NUMCRK=4
  327.       CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,2,2)
  328.       FALSTR=SIGCP
  329.       IF (KPRI.EQ.0) GO TO 65
  330.       GO TO 70
  331. C
  332. C     TEST TO SEE CRACKING OR CRUSHING OCCURS FOR THE FIRST TIME
  333. C
  334.    59 IF (KPRI.EQ.0) GO TO 65
  335.       IF (MODEL.GT.4) GO TO 150
  336.       PTOT=-PGRAV + P1
  337.       IF (PTOT.LE.0.0) GO TO 65
  338.       NUMCRK=1
  339.       IF (P2.GT.PGRAV) NUMCRK=2
  340.       IF (P3.GT.PGRAV) NUMCRK=3
  341.       DCA(1)=RLMN(1,1)
  342.       DCA(2)=RLMN(2,1)
  343.       DCA(3)=RLMN(1,2)
  344.       DCA(4)=RLMN(2,2)
  345.       IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
  346.       IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
  347.       CRKSTR(1)=EP(1)
  348.       CRKSTR(2)=EP(2)
  349.       CRKSTR(3)=EP(3)
  350.       CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
  351.       ILFSET=1
  352. C
  353. C
  354. C
  355. C        6. PRINT STRESSES
  356. C
  357. C
  358.    65 IF (KPRI.NE.0) GO TO 70
  359.       IF (IPRI.NE.0) GO TO 66
  360.       IF (IPT.NE.1) GO TO 66
  361.       IF (NEL .EQ. 1) WRITE (6,2015)
  362.       WRITE(6,2035) NEL
  363.    66 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 67
  364. C
  365.       IF (DCA(4).LE.1.0) GO TO 165
  366.       IF (MODEL.GT.4) GO TO 150
  367.       PTOT=-PGRAV + P1
  368.       IF (PTOT.GT.0.0) ANGPRI=RLMN(2,2)
  369.       IF (ANGPRI.LE.1.0) NUMCRK=1
  370.       IF (P2.GT.PGRAV) NUMCRK=2
  371.       IF (P3.GT.PGRAV) NUMCRK=3
  372.       GO TO 160
  373. C
  374. C     CHECK FOR CRACKING OR CRUSHING OF CONCRETE FOR THE FIRST TIME
  375. C
  376.   150 IF (P1.LT.0.) GO TO 155
  377.       IF (P1.GT.FALSTR) NUMCRK=1
  378.       IF (P2.GT.FALSTR) NUMCRK=2
  379.       IF (P3.GT.FALSTR) NUMCRK=3
  380.   155 IF (P3.LE.SIGCP) NUMCRK=4
  381.       IF (NUMCRK.GT.0) ANGPRI=RLMN(2,2)
  382.       IF (NUMCRK.EQ.4) FALSTR=SIGCP
  383. C
  384.       IF (KPRI.EQ.0) GO TO 160
  385.       IF (NUMCRK.EQ.0) GO TO 70
  386.       DCA(1)=RLMN(1,1)
  387.       DCA(2)=RLMN(2,1)
  388.       DCA(3)=RLMN(1,2)
  389.       DCA(4)=RLMN(2,2)
  390.       IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
  391.       IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
  392.       CRKSTR(1)=EP(1)
  393.       CRKSTR(2)=EP(2)
  394.       CRKSTR(3)=EP(3)
  395. C
  396.       IF (NUMCRK.NE.4) GO TO 159
  397.       PGRAV=100.
  398.       CRKSTR(1)=SIGCP
  399.       CRKSTR(2)=EPSCP
  400. C
  401.   159 CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
  402.       ILFSET=1
  403. C
  404.       GO TO 70
  405. C
  406.   160 IF (ANGPRI.GT.10.) GO TO 67
  407.       CALL DCRAK3 (C,STRESS,RLMN,MODEL,NUMCRK,1,2)
  408. C
  409.   165 NF=NUMCRK + 1
  410.       IF (INDNL .EQ. 2) CALL CAUCH3
  411.       IF (IPRI.NE.0) GO TO 70
  412.       GO TO (61,62,63,64,68), NF
  413.    61 WRITE(6,2040) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  414.       GO TO 70
  415.    62 WRITE(6,2041) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  416.       GO TO 70
  417.    63 WRITE(6,2042) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  418.       GO TO 70
  419.    64 WRITE(6,2043) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  420.       GO TO 70
  421.    68 WRITE (6,2044) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  422.       GO TO 70
  423.    67 IF (INDNL .EQ. 2) CALL CAUCH3
  424.       IF (IPRI.NE.0) GO TO 70
  425.       WRITE (6,2045) IPT,(STRESS(I),I=1,6),P1,P2,P3,FALSTR
  426. C
  427. C
  428. C        7. UPDATE STRESSES AND STRAINS
  429. C
  430. C
  431.    70 SIG(1)=STRESS(1)
  432.       SIG(2)=STRESS(2)
  433.       SIG(3)=STRESS(3)
  434.       SIG(4)=STRESS(4)
  435.       SIG(5)=STRESS(5)
  436.       SIG(6)=STRESS(6)
  437. C
  438.       EPS(1)=STRAIN(1)
  439.       EPS(2)=STRAIN(2)
  440.       EPS(3)=STRAIN(3)
  441.       EPS(4)=STRAIN(4)
  442.       EPS(5)=STRAIN(5)
  443.       EPS(6)=STRAIN(6)
  444.       IF (KPRI .EQ. 0) RETURN
  445.       IF (ICOUNT.EQ.3) RETURN
  446. C
  447.       IF (MODEL.EQ.4) GO TO 71
  448.       IF (PGRAV.NE.100.) GO TO 69
  449.       E=0.
  450.       GO TO 100
  451. C
  452.    69 SBAR=((SIG(1)-SIG(2))**2+(SIG(1)-SIG(3))**2+(SIG(2)-SIG(3))**2)/6.
  453.       SBAR=SBAR + SIG(4)**2 + SIG(5)**2 + SIG(6)**2
  454.       EVI=DSQRT(SBAR) + ALFA*(SIG(1) + SIG(2) + SIG(3))
  455.       IF (IKAS.EQ.1 .AND. ILFSET.EQ.1) EVMAX=EVI
  456. C
  457.    71 IF (EVI.GT.EVMAX) EVMAX=EVI
  458. C
  459. C
  460. C        8. FORM THE STRESS-STRAIN RELATIONSHIP
  461. C
  462. C
  463. C
  464. C     IN DIVERGENCE FORMULATION (IEQREF=1) FORM THE INITIAL ELASTIC C
  465. C
  466.       IF (IEQREF.EQ.1) GO TO 85
  467. C
  468.       IF (EVI.LT.EVMAX) GO TO 75
  469. C
  470. C     NOW LOADING BEYOND PREVIOUS MAXIMUM VALUE
  471. C
  472.    74 IF (MODEL.EQ.4) EVTOT=EVMAX + EVGRAV
  473.       IK=J
  474.       IKAS=1
  475.       ITEM=2
  476.       GO TO 5
  477. C
  478.    75 IF (IKAS) 100,85,85
  479. C
  480. C     WAS LOADING, NOW UNLOADING FROM THE CURRENT MAXIMUM
  481. C
  482.    85 IF (MODEL.EQ.4) GO TO 90
  483.       E=EKK(1)
  484.       VNU=EKK(2)
  485.       MOD45=1
  486.       GO TO 100
  487. C
  488.    90 RKUNLO=RKUN(I) + RATIO * (RKUN(J) - RKUN(I))
  489.       G=G*(RKUNLO/RK)
  490.       RK=RKUNLO
  491. C
  492. C     WAS UNLOADING, NOW FURTHUR UNLOADING OR RELOADING TO PREVIOUS MAX
  493. C
  494.   100 IF (MODEL.EQ.4) GO TO 95
  495.       IF (E.LE.0.) E=EKK(1)*STIFAC
  496.       RK=E/(3.*(1. - 2.*VNU))
  497.       G=E/(2.*(1. + VNU))
  498.       IF (PGRAV.EQ.100.) GO TO 101
  499.       IF (MOD45.EQ.2) GO TO 130
  500.    95 IF (MODEL.EQ.4 .AND. ICRACK.LT.1) GO TO 101
  501.       IF (DCA(4) .LE. 1.0) GO TO 130
  502. C
  503. C     ISOTROPIC STRESS-STRAIN LAW
  504. C
  505.   101 DUM=0.6666667 * G
  506.       A1=RK + 2.*DUM
  507.       B1=RK - DUM
  508. C
  509.       DO 110 I=1,6
  510.       DO 110 J=1,6
  511.   110 C(I,J)=0.0
  512. C
  513.       C(1,1)=A1
  514.       C(1,2)=B1
  515.       C(1,3)=B1
  516.       C(2,1)=B1
  517.       C(2,2)=A1
  518.       C(2,3)=B1
  519.       C(3,1)=B1
  520.       C(3,2)=B1
  521.       C(3,3)=A1
  522.       DO 120 I=4,6
  523.   120 C(I,I)=G
  524. C
  525.       GO TO 200
  526. C
  527. C     CRACKED / ORTHOTROPIC STRESS-STRAIN LAW
  528. C
  529.   130 CALL DCRAK3 (C,SIG,RLMN,MODEL,NUMCRK,2,1)
  530. C
  531.   200 IF (ITHERM.GT.0) CALL THERM3 (NODS,NOD9,XYZ,EKK,TEMPV2,EPS,TMPOLD)
  532.       IF (MODEL.EQ.5) EVGRAV=TMPOLD
  533. C
  534.       IF (IUPDT .EQ. 0) RETURN
  535.       DO 210 I=1,22
  536.   210 WA(I)=DUMWA(I)
  537.       RETURN
  538. C
  539. C
  540.  2000 FORMAT(///36H ***ERROR  CURRENT VOLUMETRIC STRAIN,E14.6,2X,
  541.      1       13HFOR ELEMENT (,I2,1H)/11X,21HEXCEEDS TABLE MAXIMUM,
  542.      2       E14.6//8H ***STOP)
  543.  2015 FORMAT (/10H ELMT  INT,101X,7H(PGRAV),/10H  NO   PT ,
  544.      1        2X,7HSIGMAXX,4X,7HSIGMAYY,4X,7HSIGMAZZ,4X,7HSIGMAXY,4X,
  545.      2        7HSIGMAXZ,4X,7HSIGMAYZ,3X,8HSIGMA P1,3X,8HSIGMA P2,3X,
  546.      3        8HSIGMA P3,4X,7HFAILSTR /)
  547.  2035 FORMAT (I4)
  548.  2040 FORMAT (I9,1X,10E11.3,8H  CLOSED  )
  549.  2041 FORMAT (I9,1X,10E11.3,8H 1 CRACK  )
  550.  2042 FORMAT (I9,1X,10E11.3,8H 2CRACKS  )
  551.  2043 FORMAT (I9,1X,10E11.3,8H 3CRACKS  )
  552.  2044 FORMAT (I9,1X,10E11.3,8H CRUSHED  )
  553.  2045 FORMAT (I9,1X,10E11.3,8H NOCRACK  )
  554. C
  555.       END
  556. C *CDC* *DECK PRNCP3
  557. C *UNI* )FOR,IS N.PRNCP3, R.PRNCP3
  558.       SUBROUTINE PRNCP3 (STR,EPS,RLMN,SP1,SP31,SP32,SP33,EPSL,PGRAV,
  559.      1                   MODEL,KKK)
  560. C
  561.       IMPLICIT REAL*8 (A-H,O-Z)
  562. C
  563.       COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
  564.      1               RAM5,RBM5,RCM5,ICRACK,MOD45
  565.       COMMON /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGMA(6),TEP(6),EP(6),YP(3),
  566.      1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
  567.       COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  568. C
  569.       DIMENSION STR(6),EPS(1),RLMN(3,3),SP1(1),SP31(1),SP32(1),SP33(1),
  570.      1          EPSL(1),T(6,6),S(3,3),IPRM(3),IPERM(3),ICOL(3)
  571.       EQUIVALENCE (SIGMA(1),P1),(SIGMA(2),P2),(SIGMA(3),P3)
  572.       DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
  573. C
  574. C     FIND THE STRESS INVARIANTS - 1. MEAN STRESS
  575. C
  576.       IF (KKK.GT.1) GO TO 95
  577.       STRAV=(STR(1) + STR(2) + STR(3))/3.
  578. C
  579.       S(1,1)=STR(1) - STRAV
  580.       S(2,2)=STR(2) - STRAV
  581.       S(3,3)=STR(3) - STRAV
  582.       S(1,2)=STR(4)
  583.       S(1,3)=STR(5)
  584.       S(2,3)=STR(6)
  585.       S(2,1)=S(1,2)
  586.       S(3,1)=S(1,3)
  587.       S(3,2)=S(2,3)
  588. C
  589. C     2. J2 = SBAR**2 = 1/2 SIJ*SIJ
  590. C
  591.       SBAR=0.
  592.       DO 20 I=1,3
  593.       DO 20 J=1,3
  594.    20 SBAR=SBAR + S(I,J)*S(I,J)
  595.       SBAR=DSQRT(SBAR/2.)
  596.       SBTOL=DABS(STRAV)*1.D-8
  597.       IF (SBAR.LE.SBTOL) SBAR=0.
  598.       IF (SBAR.EQ.0.) GO TO 31
  599. C
  600. C     3. J3 = 1/3 SIJ*SJK*SKI
  601. C
  602.       RJ3=0.
  603.       DO 30 I=1,3
  604.       DO 30 J=1,3
  605.       DO 30 K=1,3
  606.    30 RJ3=RJ3 + S(I,J)*S(J,K)*S(K,I)
  607.       RJ3=RJ3/3.
  608. C
  609. C     MODIFIED STRESS INVARIANT PHI - SIN(3*PHI)=-(3*3**.5/2)*J3/SBAR**3
  610. C
  611.       TEMP=-3.*DSQRT(3.0D0)/2.
  612.       TEMP=TEMP*RJ3/SBAR**3
  613.    31 IF (SBAR.EQ.0.) TEMP=0.
  614.       IF (DABS(TEMP) .LE. 1.D0) GO TO 32
  615.       IF (DABS(TEMP) .LE. 1.0001) GO TO 34
  616.       WRITE (6,2000)
  617.       STOP
  618.    34 IF (TEMP .LT. (-1.D0)) TEMP=-1.D0
  619.       IF (TEMP .GT. 1.D0) TEMP=1.D0
  620.    32 PI=4.D0*DATAN(1.D0)
  621.       TEMPCS=DSQRT(1.D0-TEMP*TEMP)
  622.       PHI=DATAN2(TEMP,TEMPCS)
  623.       IF (PHI.GT.PI) PHI=PHI - 2.D0*PI
  624.       PHI=PHI/3.D0
  625. C
  626. C     FIND PRINCIPAL STRESSES
  627. C
  628.       A1=2.*SBAR/DSQRT(3.0D0)
  629.       SIGMA(1)=A1*DSIN(PHI + 2.*PI/3.) + STRAV
  630.       SIGMA(2)=A1*DSIN(PHI) + STRAV
  631.       SIGMA(3)=A1*DSIN(PHI + 4.*PI/3.) + STRAV
  632.       SIGMA(4)=0.
  633.       SIGMA(5)=0.
  634.       SIGMA(6)=0.
  635. C
  636. C     FIND THE DIRECTION COSINES OF THE PRINCIPAL STRESSES
  637. C
  638.       TOL=0.01
  639.       IND=0
  640.       SPREAD=SIGMA(1) - SIGMA(3)
  641.       ROERR=DABS(SIGMA(1))*0.000001
  642.       IF (SIGMA(1).EQ.0.) ROERR=DABS(SIGMA(3))*0.000001
  643.       IF (SPREAD.LE.ROERR) GO TO 82
  644.       DIF1=SIGMA(1) - SIGMA(2)
  645.       DIF2=SIGMA(2) - SIGMA(3)
  646.       IF (DIF1.LT.SPREAD*TOL) IND=3
  647.       IF (DIF2.LT.SPREAD*TOL) IND=1
  648. C
  649.       N=3
  650.       I1=IND
  651.       IF (IND.EQ.0) I1=1
  652.       NEIG=2
  653.       DO 78 NX=1,NEIG
  654. C
  655.       DO 35 J1=1,N
  656.       ICOL(J1)=J1
  657.       S(J1,J1)=STR(J1) - SIGMA(I1)
  658.    35 RLMN(J1,I1)=0.
  659.       S(1,2)=STR(4)
  660.       S(1,3)=STR(5)
  661.       S(2,3)=STR(6)
  662.       S(2,1)=S(1,2)
  663.       S(3,1)=S(1,3)
  664.       S(3,2)=S(2,3)
  665. C
  666. C     GAUSS ELIMINATION WITH SEARCH FOR LARGEST PIVOT
  667. C
  668.       DO 65 J=1,N
  669. C
  670.       PIVI=0.
  671.       DO 40 I=J,N
  672.       DO 40 K=J,N
  673.       IF (DABS(PIVI).GT.DABS(S(I,K))) GO TO 40
  674.       IMAX=I
  675.       KMAX=K
  676.       PIVI=S(I,K)
  677.    40 CONTINUE
  678.       IF (KMAX.EQ.J) GO TO 47
  679. C
  680.       ISAVE=ICOL(KMAX)
  681.       ICOL(KMAX)=ICOL(J)
  682.       ICOL(J)=ISAVE
  683.       DO 45 JJ=1,N
  684.       SAVE=S(JJ,KMAX)
  685.       S(JJ,KMAX)=S(JJ,J)
  686.    45 S(JJ,J)=SAVE
  687. C
  688.    47 PIVI=1./PIVI
  689. C
  690.       DO 50 K=J,N
  691.       IF (IMAX.EQ.J) GO TO 50
  692.       SAVE=S(J,K)
  693.       S(J,K)=S(IMAX,K)
  694.       S(IMAX,K)=SAVE
  695.    50 S(J,K)=S(J,K)*PIVI
  696. C
  697.       IF (J.EQ.(N-1)) GO TO 70
  698.       I2=J + 1
  699.       DO 65 K2=I2,N
  700.       DO 65 J2=I2,N
  701.    65 S(K2,J2)=S(K2,J2) - S(K2,J)*S(J,J2)
  702. C
  703.    70 N1=N - 1
  704.       RLMN(ICOL(N),I1)=1.
  705.       DO 75 J=1,N1
  706.       IA=N
  707.       DO 75 K=1,J
  708.       RLMN(ICOL(N-J),I1)=RLMN(ICOL(N-J),I1)- S(N-J,IA)*RLMN(ICOL(IA),I1)
  709.    75 IA=IA - 1
  710. C
  711.       RMAX=0.
  712.       DO 74 L1=1,3
  713.    74 IF (DABS(RLMN(L1,I1)).GT.RMAX) RMAX=DABS(RLMN(L1,I1))
  714.       RMAX=RMAX*0.0001
  715.       DO 76 L1=1,3
  716.    76 IF (DABS(RLMN(L1,I1)).LE.RMAX) RLMN(L1,I1)=0.
  717.       XLN=RLMN(1,I1)**2 + RLMN(2,I1)**2 + RLMN(3,I1)**2
  718.       XLN=1.0/DSQRT(XLN)
  719.       IF (RLMN(3,I1).LT.0.) XLN=-XLN
  720.       DO 77 J1=1,3
  721.    77 RLMN(J1,I1)=RLMN(J1,I1)*XLN
  722.       I1=3
  723.       IF (IND.EQ.3) I1=1
  724.    78 CONTINUE
  725. C
  726.       IND=3
  727.       I2=IPRM(IND)
  728.       I1=IPRM(I2)
  729.       X=RLMN(2,IND)*RLMN(3,I2) - RLMN(3,IND)*RLMN(2,I2)
  730.       Y=RLMN(3,IND)*RLMN(1,I2) - RLMN(1,IND)*RLMN(3,I2)
  731.       Z=RLMN(1,IND)*RLMN(2,I2) - RLMN(2,IND)*RLMN(1,I2)
  732.       XLN=1./DSQRT(X*X + Y*Y + Z*Z)
  733.       IF (Z.LT.0.) XLN=-XLN
  734.       RLMN(1,I1)=X*XLN
  735.       RLMN(2,I1)=Y*XLN
  736.       RLMN(3,I1)=Z*XLN
  737.       GO TO 84
  738. C
  739.    82 DO 83 I1=1,3
  740.       DO 83 J1=1,3
  741.       RLMN(J1,I1)=0.
  742.    83 IF (I1.EQ.J1) RLMN(J1,I1)=1.
  743.    84 CONTINUE
  744. C
  745. C     STRAIN TRANSFORMATION MATRIX
  746. C
  747.       DO 90 I1=1,3
  748.       I2=IPRM(I1)
  749.       I3=IPERM(I1)
  750.       DO 86 J1=1,3
  751.       J2=IPRM(J1)
  752.       J3=IPERM(J1)
  753.       T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
  754.       T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
  755.       T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
  756.       T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
  757.    86 CONTINUE
  758.    90 CONTINUE
  759. C
  760. C     FIND STRAINS IN THE PRINCIPAL STRESS COORDINATE SYSTEM
  761. C
  762.    95 DO 110 I=1,6
  763.       EPSL(I)=0.
  764.       DO 110 J=1,6
  765.   110 EPSL(I)=EPSL(I) + T(I,J)*EPS(J)
  766.       IF (KKK.EQ.2) RETURN
  767.       IF (MODEL.EQ.4) RETURN
  768.       IF (PGRAV.EQ.100.) RETURN
  769. C
  770. C     FIND FAILURE STRESSES FROM THE FAILURE ENVELOPE
  771. C
  772.       SIGCP=SIGMAC
  773.       EPSCP=EPSC
  774.       FALSTR=SIGMAT
  775.       IF (P1.LT.0. .AND. P2.LT.0. .AND. P3.LT.0.) GO TO 135
  776.       IF (P2.LT.0. .AND. P3.LT.0.) GO TO 130
  777.       IF (P3.LT.0.) GO TO 120
  778.       FALSTR=SIGMAT
  779.       GO TO 200
  780.   120 FALSTR=SIGMAT*(1. - P3/SIGMAC)
  781.       GO TO 200
  782.   130 SP31I=SP31(1)
  783.       SP32I=SP32(1)
  784.       SP33I=SP33(1)
  785.       TEMP=0.
  786.       GO TO 150
  787. C
  788.   135 TEMP=P1/SIGMAC
  789.       DO 140 I=2,6
  790.       J=I - 1
  791.       IF (TEMP.LT.SP1(I)) GO TO 145
  792.   140 CONTINUE
  793.       WRITE (6,3000) P1
  794.       WRITE (6,3100) NEL,IPT,P1,P2,P3
  795.       STOP
  796. C
  797.   145 DSP=SP1(I) - SP1(J)
  798.       DSPI=TEMP - SP1(J)
  799.       FRAC=DSPI/DSP
  800.       SP31I=SP31(J) + FRAC*(SP31(I) - SP31(J))
  801.       SP32I=SP32(J) + FRAC*(SP32(I) - SP32(J))
  802.       SP33I=SP33(J) + FRAC*(SP33(I) - SP33(J))
  803. C
  804.   150 RATIO=P2/SIGMAC
  805.       IF (RATIO.GT.BETA*SP32I) GO TO 160
  806.       SLOPE=(SP32I - SP31I)/(BETA*SP32I - TEMP)
  807.       SIGCP=SP31I*SIGMAC + SLOPE*(P2 - P1)
  808.       IF (P1.GT.0.) SIGCP=SP31I*SIGMAC + SLOPE*P2
  809.       GO TO 170
  810.   160 SLOPE=(SP33I - SP32I)/(SP33I - BETA*SP32I)
  811.       SIGCP=SP32I*SIGMAC + SLOPE*(P2 - BETA*SP32I*SIGMAC)
  812. C
  813.   170 IF (SIGCP.LT.SIGMAC) EPSCP=GAMA*EPSC*SIGCP/SIGMAC
  814.       IF (P1.GE.0.) FALSTR=SIGMAT*(1. - P2/SIGCP)*(1. - P3/SIGCP)
  815.       IF (FALSTR.LT.0.001*SIGMAT) FALSTR=SIGMAT
  816.       IF (P1.LT.0.) FALSTR=SIGCP
  817. C
  818.   200 RETURN
  819. C
  820.  2000 FORMAT (//46H STOP, ERROR IN PRINCIPAL STRESS CALCULATIONS  /)
  821.  3000 FORMAT (1H1,52H*** ERROR STOP, CURRENT VALUE OF PRINCIPAL STRESS 1
  822.      1=,E15.5,50H IS LARGER THAN THE MAXIMUM INPUT VALUE FOR SP1(6))
  823.  3100 FORMAT (//36H ERROR OCCURED IN SUBROUTINE PRNCP3.
  824.      1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
  825.      2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
  826. C
  827.       END
  828. C *CDC* *DECK THERM3
  829. C *UNI* )FOR,IS N.THERM3, R.THERM3
  830.       SUBROUTINE THERM3 (NODS,NOD9,XYZ,PROP,TEMPV2,EPS,TMPOLD)
  831. C
  832.       IMPLICIT REAL*8 (A-H,O-Z)
  833. C
  834.       COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),R,S,T
  835.       COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
  836.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  837. C
  838.       DIMENSION NODS(1),NOD9(1),XYZ(1),PROP(1),TEMPV2(1),H(21),P(3,21),
  839.      1          XJ(3,3),EPS(1)
  840. C
  841. C     CALCULATE INITIAL STRAIN DUE TO TEMPERATURE
  842. C
  843.       IINTP=1
  844.       CALL FUNCT (R,S,T,H,P,NOD9,XJ,DET,XYZ,IINTP)
  845. C
  846.       TEMP2=0.
  847.       DO 20 K=1,IEL
  848.       KK=NODS(K)
  849.    20 TEMP2=TEMP2 + H(K)*TEMPV2(KK)
  850.       CTEMP=TEMP2
  851.       DEPST=PROP(3)*(CTEMP - TMPOLD)
  852. C
  853. C     CALCULATE STRESS CONTRIBUTION TO BE ADDED TO NODAL FORCE VECTOR
  854. C
  855.       IST=3
  856.       DO 50 I=1,IST
  857.       EPS(I)=EPS(I) + DEPST
  858.       DO 50 J=1,IST
  859.    50 STRESS(I)=STRESS(I) - C(I,J)*DEPST
  860. C
  861. C     UPDATE OLD TEMPERATURE TO CURRENT TEMPERATURE
  862. C
  863.       TMPOLD=CTEMP
  864. C
  865.       RETURN
  866. C
  867.       END
  868. C *CDC* *DECK CRAK3D
  869. C *UNI* )FOR,IS N.CRAK3D, R.CRAK3D
  870.       SUBROUTINE CRAK3D (STR,EPS,DCA,PGRAV,CRKSTR,SP1,SP31,SP32,SP33,
  871.      1                   RLMN,EPSL,NUMCRK,MODEL,KKK)
  872. C
  873.       IMPLICIT REAL*8 (A-H,O-Z)
  874. C
  875.       COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
  876.      1               RAM5,RBM5,RCM5,ICRACK,MOD45
  877.       COMMON /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
  878.      1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
  879.       COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  880. C
  881.       DIMENSION STR(1),EPS(1),DCA(4),CRKSTR(3),SP1(1),SP31(1),SP32(1),
  882.      1          SP33(1),RLMN(3,3),EPSL(6),T(6,6),IPRM(3),IPERM(3),SIG(3)
  883.       DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
  884. C
  885.       IF (KKK.EQ.2) GO TO 95
  886.       RLMN(1,1) = DCA(1)
  887.       NUMCRK=1
  888.       IF (DCA(1) .LE. -50.) NUMCRK=2
  889.       IF (DCA(1) .GE. 49.) NUMCRK=3
  890.       IF (DCA(1) .GE. 99.) NUMCRK=0
  891.       IF (NUMCRK.EQ.2) RLMN(1,1) = DCA(1) + 51.
  892.       IF (NUMCRK.EQ.3) RLMN(1,1) = DCA(1) - 50.
  893.       IF (NUMCRK.EQ.0) RLMN(1,1) = DCA(1) - 100.
  894.       NCROLD=NUMCRK
  895.       IF (KKK.EQ.3) GO TO 107
  896. C
  897. C     GENERATE DIRECTION COSINES ARRAY RLMN FROM DCA
  898. C
  899.       RLMN(2,1) = DCA(2)
  900.       RLMN(1,2) = DCA(3)
  901.       RLMN(2,2) = DCA(4)
  902.       TEMP1=RLMN(1,1)*RLMN(1,1) + RLMN(2,1)*RLMN(2,1)
  903.       TEMP2=RLMN(1,2)*RLMN(1,2) + RLMN(2,2)*RLMN(2,2)
  904.       IF (TEMP1.LE.1.00001 .AND. TEMP2.LE.1.00001) GO TO 20
  905.       WRITE (6,3200) (DCA(I),I=1,4)
  906.       STOP
  907. C
  908.    20 IF (TEMP1.GT.1.) TEMP1=1.
  909.       IF (TEMP2.GT.1.) TEMP2=1.
  910.       RLMN(3,1)=DSQRT(1. - TEMP1)
  911.       RLMN(3,2)=DSQRT(1. - TEMP2)
  912. C
  913.       X=RLMN(2,1)*RLMN(3,2) - RLMN(3,1)*RLMN(2,2)
  914.       Y=RLMN(3,1)*RLMN(1,2) - RLMN(1,1)*RLMN(3,2)
  915.       Z=RLMN(1,1)*RLMN(2,2) - RLMN(2,1)*RLMN(1,2)
  916.       XLN=DSQRT(X*X + Y*Y + Z*Z)
  917.       XLN=1.0/XLN
  918.       RLMN(1,3)=X*XLN
  919.       RLMN(2,3)=Y*XLN
  920.       RLMN(3,3)=Z*XLN
  921. C
  922. C     OBTAIN CRACK PLANE STRESSES AND STRAINS
  923. C
  924. C     STRAIN TRANSFORMATION
  925. C
  926.       DO 90 I1=1,3
  927.       I2=IPRM(I1)
  928.       I3=IPERM(I1)
  929.       DO 80 J1=1,3
  930.       J2=IPRM(J1)
  931.       J3=IPERM(J1)
  932.       T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
  933.       T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
  934.       T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
  935.       T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
  936.    80 CONTINUE
  937.    90 CONTINUE
  938. C
  939.    95 DO 100 I=1,6
  940.       EPSL(I)=0.
  941.       DO 100 J=1,6
  942.   100 EPSL(I)=EPSL(I) + T(I,J)*EPS(J)
  943.       IF (KKK.EQ.2) RETURN
  944. C
  945. C     STRESS TRANSFORMATION
  946. C
  947.       DO 105 I=1,3
  948.       DO 105 J=4,6
  949.       T(J,I)=T(J,I)*0.5
  950.   105 T(I,J)=2.*T(I,J)
  951. C
  952.       DO 108 I=1,6
  953.       SIGP(I)=0.
  954.       DO 108 J=1,6
  955.   108 SIGP(I)=SIGP(I) + T(I,J)*STR(J)
  956. C
  957. C     TEST TO SEE WHICH DIRECTIONS HAVE OPEN CRACKS AT CURRENT STRESSES
  958. C
  959.   107 IF (MODEL.EQ.4) FALSTR=PGRAV
  960.       IF (MODEL.EQ.4) GO TO 109
  961.       FALSTR=SIGMAT
  962.       SIGCP=SIGMAC
  963.       EPSCP=EPSC
  964.       SIG(1)=SIGP(1)
  965.       SIG(2)=SIGP(2)
  966.       SIG(3)=SIGP(3)
  967. C
  968.   109 NF=NUMCRK + 1
  969.       GO TO (110,111,180,190), NF
  970. C
  971.   110 IF (SIGP(1).LT.FALSTR .AND. SIGP(2).LT.FALSTR .AND.
  972.      1    SIGP(3).LT.FALSTR) GO TO 112
  973.       NUMCRK=1
  974.       DCA(1)=DCA(1) - 100.
  975.       CRKSTR(1)=EPSL(1)
  976.       CRKSTR(2)=EPSL(2)
  977.       CRKSTR(3)=EPSL(3)
  978.       GO TO 112
  979. C
  980.   111 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=0
  981.       R11=(SIGP(2) + SIGP(3))*0.5
  982.       R12=(SIGP(2) - SIGP(3))*0.5
  983.       RAD=DSQRT(R12*R12 + SIGP(6)*SIGP(6))
  984.       SIG(2)=R11 + RAD
  985.       SIG(3)=R11 - RAD
  986.       IF (MODEL.EQ.5 .AND. SIG(3).LT.0.) FALSTR=SIGMAT*(1. - SIG(3)/
  987.      1                                                          SIGMAC)
  988.       IF (SIG(2).GT.FALSTR) NUMCRK=2
  989.       IF (SIG(3).GT.FALSTR) NUMCRK=3
  990.       IF (NUMCRK.EQ.0) DCA(1)=DCA(1) + 100.
  991.       IF (NUMCRK.LE.1) GO TO 112
  992. C
  993.       S11=(EPSL(2) + EPSL(3))*0.5
  994.       S12=(EPSL(2) - EPSL(3))*0.5
  995.       RAD=DSQRT(S12*S12 + EPSL(6)*EPSL(6)/4.)
  996.       EPS2=S11 + RAD
  997.       EPS3=S11 - RAD
  998.       IF (NUMCRK.EQ.2) CRKSTR(2)=EPS2
  999.       IF (NUMCRK.EQ.3) CRKSTR(3)=EPS3
  1000.       IF (NUMCRK.EQ.2) DCA(1)=DCA(1) - 51.
  1001.       IF (NUMCRK.EQ.3) DCA(1)=DCA(1) + 50.
  1002.       IF (SIGP(6).EQ.0.) GO TO 112
  1003.       SIGP(2)=SIG(2)
  1004.       SIGP(3)=SIG(3)
  1005.       EPSL(2)=EPS2
  1006.       EPSL(3)=EPS3
  1007.       EPSL(6)=0.
  1008.       ANG=DATAN(1.0D0)
  1009.       IF (DABS(R12).GT.0.000001) ANG=DATAN2(SIGP(6),R12)*0.5
  1010.       SIGP(6)=0.
  1011.       SG=DSIN(ANG)
  1012.       CG=DCOS(ANG)
  1013.       DCA(3)=RLMN(1,2)*CG + RLMN(1,3)*SG
  1014.       DO 113 J=1,3
  1015.       DUMY= RLMN(J,2)*CG + RLMN(J,3)*SG
  1016.       RLMN(J,3)=-RLMN(J,2)*SG + RLMN(J,3)*CG
  1017.   113 RLMN(J,2)=DUMY
  1018.       DCA(3)=RLMN(1,2)
  1019.       DCA(4)=RLMN(2,2)
  1020. C     CHECK FOR COMPRESSIVE FAILURE OF CONCRETE
  1021. C
  1022.   112 IF (MODEL.EQ.4) RETURN
  1023. C
  1024. C     ARRANGE PRINCIPAL STRESSES
  1025. C
  1026.   114 IS=0
  1027.       DO 116 I=1,2
  1028.       IF (SIG(I + 1).LE.SIG(I)) GO TO 116
  1029.       IS=IS + 1
  1030.       TEMP=SIG(I + 1)
  1031.       SIG(I + 1)=SIG(I)
  1032.       SIG(I)=TEMP
  1033.   116 CONTINUE
  1034.       IF (IS.GT.0) GO TO 114
  1035.       P1=SIG(1)
  1036.       P2=SIG(2)
  1037.       P3=SIG(3)
  1038. C
  1039.       IF (P3.GE.0.) GO TO 200
  1040.       IF (P2.LT.0.) GO TO 115
  1041.       IF (P3.GT.SIGMAC) GO TO 200
  1042.       GO TO 185
  1043.   115 IF (P1.LT.0.) GO TO 135
  1044.       SP31I=SP31(1)
  1045.       SP32I=SP32(1)
  1046.       SP33I=SP33(1)
  1047.       TEMP=0.
  1048.       GO TO 150
  1049.   135 TEMP=P1/SIGMAC
  1050.       DO 140 I=2,6
  1051.       J=I - 1
  1052.       IF (TEMP.LT.SP1(I)) GO TO 145
  1053.   140 CONTINUE
  1054.       WRITE (6,3000) P1
  1055.       WRITE (6,3100) NEL,IPT,P1,P2,P3
  1056.       STOP
  1057. C
  1058.   145 DSP=SP1(I) - SP1(J)
  1059.       DSPI=TEMP - SP1(J)
  1060.       FRAC=DSPI/DSP
  1061.       SP31I=SP31(J) + FRAC*(SP31(I) - SP31(J))
  1062.       SP32I=SP32(J) + FRAC*(SP32(I) - SP32(J))
  1063.       SP33I=SP33(J) + FRAC*(SP33(I) - SP33(J))
  1064. C
  1065.   150 RATIO=P2/SIGMAC
  1066.       IF (RATIO.GT.BETA*SP32I) GO TO 160
  1067.       SLOPE=(SP32I - SP31I)/(BETA*SP32I - TEMP)
  1068.       SIGCP=SP31I*SIGMAC + SLOPE*(P2 - P1)
  1069.       IF (P1.GT.0.) SIGCP=SP31I*SIGMAC + SLOPE*P2
  1070.       GO TO 170
  1071.   160 SLOPE=(SP33I - SP32I)/(SP33I - BETA*SP32I)
  1072.       SIGCP=SP32I*SIGMAC + SLOPE*(P2 - BETA*SP32I*SIGMAC)
  1073.   170 IF (SIGCP.LT.SIGMAC) EPSCP=GAMA*EPSC*SIGCP/SIGMAC
  1074.       IF (P3.LE.SIGCP) GO TO 185
  1075.       GO TO 200
  1076. C
  1077.   180 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=1
  1078.       IF (EPSL(2).LT.0. .AND. EPSL(2).LT.CRKSTR(2)) NUMCRK=1
  1079.       IF (NUMCRK.EQ.1) DCA(1) = DCA(1) + 51.
  1080.       IF (NUMCRK.NE.1 .AND. SIGP(3).GE.FALSTR) NUMCRK=3
  1081.       IF (NUMCRK.EQ.3) DCA(1) = DCA(1) + 101.
  1082.       IF (MODEL.NE.5 .OR. SIGP(3).GT.SIGMAC) GO TO 200
  1083. C
  1084.   185 NUMCRK=4
  1085.       CRKSTR(1)=SIGCP
  1086.       CRKSTR(2)=EPSCP
  1087.       FALSTR=SIGCP
  1088.       PGRAV=100.
  1089.       GO TO 200
  1090. C
  1091.   190 IF (EPSL(1).LT.0. .AND. EPSL(1).LT.CRKSTR(1)) NUMCRK=2
  1092.       IF (EPSL(2).LT.0. .AND. EPSL(2).LT.CRKSTR(2)) NUMCRK=2
  1093.       IF (EPSL(3).LT.0. .AND. EPSL(3).LT.CRKSTR(3)) NUMCRK=2
  1094.       IF (NUMCRK.EQ.2) DCA(1) = DCA(1) - 101.
  1095. C
  1096.   200 IF (KKK.EQ.3 .AND. NCROLD.NE.NUMCRK) ILFSET=1
  1097.       RETURN
  1098. C
  1099.  3000 FORMAT (1H1,52H*** ERROR STOP, CURRENT VALUE OF PRINCIPAL STRESS 1
  1100.      1=,E15.5,50H IS LARGER THAN THE MAXIMUM INPUT VALUE FOR SP1(6))
  1101.  3100 FORMAT (//36H ERROR OCCURED IN SUBROUTINE CRAK3D.
  1102.      1         /14H FOR ELEMENT =,I5, 8H AT IPT=,I5,
  1103.      2        /37H CURRENT PRINCIPAL/CRACK STRESSES ARE,(3E15.5/))
  1104.  3200 FORMAT (1H1///46H STOP, ERROR IN DIRECTION COSINES CALCULATIONS,
  1105.      1             /35H ERROR OCCURED IN SUBROUTINE CRAK3D,
  1106.      2             /28H CUURENT VALUES OF DCA ARE =,/4E30.20)
  1107. C
  1108.       END
  1109. C *CDC* *DECK DCRAK3
  1110. C *UNI* )FOR,IS  N.DCRAK3, R.DCRAK3
  1111.       SUBROUTINE DCRAK3 (C,SIG,RLMN,MODEL,IK,ILOCAL,KKK)
  1112. C
  1113.       IMPLICIT REAL*8 (A-H,O-Z)
  1114.       COMMON /CRACK/ GAMMA,STIFAC,SHEFAC,SIGMAT,SIGMAC,EPSC,SIGMAU,EPSU,
  1115.      1               RAM5,RBM5,RCM5,ICRACK,MOD45
  1116.       COMMON /CONCRT/ BETA,GAMA,RKAPA,ALFA,SIGP(6),TEP(6),EP(6),YP(3),
  1117.      1                E,VNU,RK,G,E12,E13,E23,EPSCP,SIGCP,FALSTR,ILFSET
  1118.       DIMENSION C(6,1),SIG(1),RLMN(3,3),D(6,6),T(6,6),DSIG(6)
  1119.      1          ,IPRM(3),IPERM(3)
  1120.       DATA IPRM/ 2, 3, 1/, IPERM/ 3, 4, 2/
  1121. C
  1122. C     COMPUTE ISOTROPIC STRESS-STRAIN LAW
  1123. C
  1124.       IF (KKK.EQ.2) GO TO 42
  1125. C
  1126.       DO 5 I=1,6
  1127.       DO 5 J=I,6
  1128.     5 C(I,J)=0.0
  1129. C
  1130.       IF (MOD45.EQ.2) GO TO 8
  1131.       DUM=2.*G/3.
  1132.       A1=RK + 2.*DUM
  1133.       B1=RK - DUM
  1134.       C(1,1)=A1
  1135.       C(1,2)=B1
  1136.       C(1,3)=B1
  1137.       C(2,2)=A1
  1138.       C(2,3)=B1
  1139.       C(3,3)=A1
  1140.       C(4,4)=G
  1141.       C(5,5)=G
  1142.       C(6,6)=G
  1143.       GO TO 10
  1144. C
  1145. C     ORTHOTROPIC STRESS-STRAIN LAW
  1146. C
  1147.     8 A1=(1. + VNU)*(1. - 2.*VNU)
  1148.       B1=(1. - VNU)/A1
  1149.       D1=VNU/A1
  1150.       C1=1./(2.*(1. + VNU))
  1151.       C(1,1)=B1*YP(1)
  1152.       C(2,2)=B1*YP(2)
  1153.       C(3,3)=B1*YP(3)
  1154.       C(1,2)=E12*D1
  1155.       C(1,3)=E13*D1
  1156.       C(2,3)=E23*D1
  1157.       C(4,4)=C1*E12
  1158.       C(5,5)=C1*E13
  1159.       C(6,6)=C1*E23
  1160. C
  1161.    10 IF (IK.EQ.0 .OR. IK.EQ.4) GO TO 30
  1162. C
  1163. C     MODIFY STRESS-STRAIN LAW TO ACCOUNT FOR CRACKING
  1164. C
  1165.       DO 12 I=4,6
  1166.    12 C(I,I)=C(I,I)*SHEFAC
  1167.       IF (MOD45.EQ.2) GO TO 13
  1168.       A2=4.*G*(RK+G/3.)/(RK+4.0*G/3.)
  1169.       B2=2.*G*(RK-2.*G/3.)/(RK+4.0*G/3.)
  1170.       C2=A2
  1171.       D2=(9.*RK*G)/(3.*RK + G)
  1172.       GO TO 14
  1173. C
  1174.    13 A1=1./(1. - VNU*VNU)
  1175.       B1=VNU*A1
  1176.       A2=A1*YP(2)
  1177.       C2=A1*YP(3)
  1178.       B2=B1*E23
  1179.       G=C1*E23
  1180.       D2=YP(3)
  1181. C
  1182.    14 IF (IK - 2) 15,20,25
  1183. C
  1184.    15 DO 16 I=1,3
  1185.    16 C(1,I)=C(1,I)*STIFAC
  1186.       C(2,2)=A2
  1187.       C(2,3)=B2
  1188.       C(3,3)=C2
  1189.       C(6,6)=G
  1190.       GO TO 30
  1191. C
  1192.    20 DO 21 I=1,2
  1193.       DO 21 J=I,3
  1194.    21 C(I,J)=C(I,J)*STIFAC
  1195.       C(3,3)=D2
  1196.       GO TO 30
  1197. C
  1198.    25 DO 26 I=1,3
  1199.       DO 26 J=I,3
  1200.    26 C(I,J)=C(I,J)*STIFAC
  1201. C
  1202.    30 DO 40 I=1,5
  1203.       DO 40 J=I,6
  1204.    40 C(J,I)=C(I,J)
  1205.       IF (ILOCAL.EQ.1) RETURN
  1206. C
  1207.    42 IF (IK.NE.4) GO TO 43
  1208.       IF (KKK.EQ.1) GO TO 90
  1209.       IF (ILOCAL.EQ.2) GO TO 90
  1210. C
  1211. C     SET UP COORDINATE TRANSFORMATION FROM CRACKED ORIENTATION
  1212. C
  1213.    43 DO 48 I1=1,3
  1214.       I2=IPRM(I1)
  1215.       I3=IPERM(I1)
  1216.       DO 47 J1=1,3
  1217.       J2=IPRM(J1)
  1218.       J3=IPERM(J1)
  1219.       T(I1   ,J1   ) = RLMN(J1,I1)*RLMN(J1,I1)
  1220.       T(I1+I3,J1   ) = RLMN(J1,I1)*RLMN(J1,I2)*2.0
  1221.       T(I1   ,J1+J3) = RLMN(J1,I1)*RLMN(J2,I1)
  1222.       T(I1+I3,J1+J3) = RLMN(J1,I1)*RLMN(J2,I2) + RLMN(J2,I1)*RLMN(J1,I2)
  1223.    47 CONTINUE
  1224.    48 CONTINUE
  1225.       IF (KKK.EQ.2) GO TO 90
  1226. C
  1227. C     ROTATE THE STRESS-STRAIN MATRIX TO GLOBAL COORDINATES
  1228. C
  1229. C     T(TRANSPOSE) * C(MATERIAL)
  1230. C
  1231.       DO 60 IR=1,6
  1232.       DO 60 IC=1,6
  1233.       D(IR,IC) = 0.0
  1234.       DO 50 IN=1,6
  1235.    50 D(IR,IC) = D(IR,IC) + T(IN,IR)* C(IN,IC)
  1236.    60 CONTINUE
  1237. C
  1238. C     T(TRANSPOSE) * C(MATERIAL) * T
  1239. C
  1240.       DO 80 IR=1,6
  1241.       DO 80 IC=IR,6
  1242.       C(IR,IC) = 0.0
  1243.       DO 70 IN=1,6
  1244.    70 C(IR,IC) = C(IR,IC) + D(IR,IN)* T(IN,IC)
  1245.    80 C(IC,IR)=C(IR,IC)
  1246. C
  1247.    90 IF (KKK.LT.2) RETURN
  1248.       IF (MODEL.EQ.4 .AND. ICRACK.LT.2) GO TO 140
  1249. C
  1250. C     REDUCE CRACKED NORMAL ( + SHEAR)STRESSES OF PREVIOUS STEP TO ZERO
  1251. C
  1252.       DO 91 I=1,6
  1253.    91 DSIG(I)=0.
  1254.       IF (IK.LT.4) GO TO 95
  1255.       EPSUP=EPSU*EPSCP/EPSC
  1256.       IF (TEP(1).GT.EPSUP .AND. TEP(2).GT.EPSUP .AND. TEP(3).GT.EPSUP)
  1257.      1    GO TO 93
  1258.       DO 92 I=1,6
  1259.    92 SIGP(I)=0.
  1260.       GO TO 95
  1261. C
  1262.    93 IF (ILOCAL.EQ.1) GO TO 140
  1263.       RETURN
  1264. C
  1265.    95 ETATAU=0.
  1266.       IF (SHEFAC .GT. 0.001) ETATAU=1.
  1267. C
  1268. C     RELEASE APPROPRIATE STRESSES
  1269. C
  1270.       NF=IK + 1
  1271.       GO TO (140,120,110,100,155), NF
  1272.   100 SIGP(3)=0.
  1273.   110 SIGP(6)=SIGP(6)*ETATAU
  1274.       SIGP(2)=0.
  1275.   120 SIGP(5)=SIGP(5)*ETATAU
  1276.       SIGP(4)=SIGP(4)*ETATAU
  1277.       SIGP(1)=0.
  1278. C
  1279. C     ROTATE STRESSES TO GLOBAL AXES
  1280. C
  1281.   140 DO 150 IR=1,6
  1282.       DO 150 IC=1,6
  1283.   150 DSIG(IR)=DSIG(IR) + T(IC,IR)*SIGP(IC)
  1284. C
  1285.   155 DO 160 I=1,6
  1286.   160 SIG(I)=DSIG(I)
  1287.       RETURN
  1288. C
  1289.       END
  1290. C *CDC* *DECK OVL41
  1291. C *CDC*       OVERLAY (ADINA,4,1)
  1292. C *CDC* *DECK ELT3D3
  1293. C *UNI* )FOR IS  N.ELT3D3, R.ELT3D3
  1294. C *CDC*       PROGRAM ELT3D3
  1295. C
  1296.       SUBROUTINE ELT3D3
  1297. C
  1298. C
  1299. C
  1300. C     MODEL = 3   (THERMOELASTIC MODEL)
  1301. C
  1302. C
  1303. C
  1304.       IMPLICIT REAL*8 (A-H,O-Z)
  1305. C
  1306.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  1307.      1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
  1308.       COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
  1309.      1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
  1310.       COMMON /DPR/ ITWO
  1311.       COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  1312.       COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
  1313.       COMMON A(1)
  1314. C
  1315.       REAL A
  1316. C
  1317.       DIMENSION IA(1)
  1318. C
  1319.       EQUIVALENCE (NPAR(10),NINT),(NPAR(7),MXNODS),(A(1),IA(1))
  1320.       EQUIVALENCE (NPAR(17),NCON)
  1321. C
  1322. C
  1323. C
  1324. C
  1325. C     FOR ADDRESSES N101,N102,.............SEE SUBROUTINE THREDM
  1326. C
  1327. C     QUANTITIES STORED FOR EACH ELEMENT
  1328. C
  1329. C        GLOBAL NODAL POINT NUMBERS
  1330. C
  1331. C
  1332. C
  1333. C
  1334.       NPT=NINT*NINT
  1335.       NN=N112+(NEL-1)*MXNODS
  1336.       IF(IND.NE.0) GO TO 100
  1337. C
  1338. C        1. INITIALIZE WORKING ARRAY
  1339. C
  1340.       CALL ITHEL3(A(NN))
  1341.       GO TO 200
  1342. C
  1343. C        2. DETERMINE MATERIAL PROPERTY SET NUMBER
  1344. C
  1345.   100 MATP=IA(N107+NEL-1)
  1346. C
  1347. C        3. DETERMINE MATERIAL PROPERTY LOCATION
  1348. C
  1349.       NM=N111+(MATP-1)*NCON*ITWO
  1350. C
  1351. C        4. DETERMINE MIDSIDE NODE ARRAY LOCATION
  1352. C
  1353.       ND9DIM=MXNODS-8
  1354.       LL=N108+(NEL-1)*ND9DIM
  1355. C
  1356. C        5. CALCULATE STRESSES AND CONSTITUTIVE LAW
  1357. C
  1358.       CALL THEL3(A(NM),A(NN),A(N6B + ITWO),A(LL))
  1359. C
  1360.   200 CONTINUE
  1361. C
  1362.       RETURN
  1363.       END
  1364. C *CDC* *DECK ITHEL3
  1365. C *UNI* )FOR,IS  N.ITHEL3, R.ITHEL3
  1366. C
  1367.       SUBROUTINE ITHEL3(IWA)
  1368. C
  1369. C
  1370. C
  1371. C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR THE
  1372. C     THERMOELASTIC MATERIAL MODEL  (MODEL = 3)
  1373. C
  1374. C
  1375. C
  1376.       IMPLICIT REAL*8 (A-H,O-Z)
  1377. C
  1378.       COMMON /DPR/ ITWO
  1379.       COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
  1380. C
  1381.       DIMENSION IWA(1)
  1382. C
  1383. C
  1384. C        1. STORE GLOBAL NODAL POINT NUMBERS
  1385. C
  1386.       II=0
  1387.       DO 15 K=1,21
  1388.       IF(NODM(K).EQ.0) GO TO 15
  1389.       II=II+1
  1390.       IWA(II)=NODM(K)
  1391.    15 CONTINUE
  1392. C
  1393.       RETURN
  1394. C
  1395.       END
  1396. C *CDC* *DECK THEL3
  1397. C *UNI* )FOR,IS  N.THEL3, R.THEL3
  1398. C
  1399.       SUBROUTINE THEL3(PROP,NDS,TEMPV2,NOD9M)
  1400. C
  1401. C
  1402. C
  1403. C     THIS SUBROUTINE CALCULATES THE STRESSES AND THE CONSTITUTIVE
  1404. C     LAW FOR THE THERMOELASTIC MATERIAL MODEL  (MODEL = 3)
  1405. C
  1406. C
  1407. C     THE FOLLOWING VARIABLES ARE USED
  1408. C
  1409. C        IST = NUMBER OF STRESS COMPONENTS
  1410. C        ISR = NUMBER OF STRAIN COMPONENTS
  1411. C        PROP2 = MATERIAL PROPERTIES AT END OF CURRENT SOLUTION STEP
  1412. C                PROP2(1) = YOUNGS MODULUS
  1413. C                PROP2(2) = POISSONS RATIO
  1414. C                PROP2(3) = MEAN COEFFICIENT OF THERMAL EXPANSION
  1415. C        TEMP2 = TEMPERATURE AT END OF CURRENT SOLUTION STEP
  1416. C        TREF = REFERENCE TEMPERATURE
  1417. C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
  1418. C        STRESS = STRESSES
  1419. C        STRAIN = TOTAL STRAINS
  1420. C        TEMPV2 = NODAL POINT TEMPERATURES AT END OF CURRENT SOLUTION
  1421. C                 STEP
  1422. C
  1423. C
  1424. C
  1425.       IMPLICIT REAL*8 (A-H,O-Z)
  1426. C
  1427.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  1428.      1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  1429.      2               SUBDD,RNGL,RNGU,DTT,TOL7,
  1430.      3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK,IST,ISR
  1431.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  1432.      1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  1433.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  1434.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  1435.       COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
  1436.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  1437.       COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
  1438.       COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
  1439. C
  1440.       DIMENSION PROP2(3),PROP(16,1),EPST(6),NDS(1),NOD9M(1),TEMPV2(1),
  1441.      1          H(21),XDM1(3,21),XDM2(3,3),XDM3(3,1)
  1442. C
  1443.       EQUIVALENCE (NPAR(3),INDNL)
  1444. C
  1445. C
  1446. C
  1447.       IF(IPT.GT.1) GO TO 5
  1448.       TOLMT=1.0D-2
  1449.       NPTS=IDINT(PROP(1,5))
  1450.       TREF=PROP(2,5)
  1451.       IINTP=1
  1452. C
  1453.       TOLL=TOLMT*DABS(PROP(1,1))
  1454.       IF(TOLL.EQ.0.0) TOLL=TOLMT
  1455.       TOLU=TOLMT*DABS(PROP(NPTS,1))
  1456.       IF(TOLU.EQ.0.0) TOLU=TOLMT
  1457. C
  1458.       RNGL=PROP(1,1) - TOLL
  1459.       RNGU=PROP(NPTS,1) + TOLU
  1460. C
  1461. C        1. INTERPOLATE NODAL POINT TEMPERATURES
  1462. C
  1463.     5 CALL FUNCT(E1,E2,E3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
  1464.       TEMP2=0.0
  1465.       DO 10 K=1,IELD
  1466.       KK=NDS(K)
  1467.    10 TEMP2=TEMP2+H(K)*TEMPV2(KK)
  1468. C
  1469. C        2. INTERPOLATE MATERIAL PROPERTY TABLES
  1470. C
  1471.       IF(TEMP2.GE.RNGL) GO TO 35
  1472.       WRITE(6,2008)
  1473.       STOP
  1474. C
  1475.    35 L=0
  1476.       DO 40 K=2,NPTS
  1477.       L=L+1
  1478.       DUM=PROP(K,1)
  1479.       IF(K.EQ.NPTS) DUM=RNGU
  1480.       IF(TEMP2.GT.DUM) GO TO 40
  1481.       GO TO 45
  1482.    40 CONTINUE
  1483.       WRITE(6,2008)
  1484.       STOP
  1485. C
  1486.    45 RATIO=(TEMP2-PROP(L,1))/(PROP(L+1,1)-PROP(L,1))
  1487. C
  1488. C     CORRECT RATIO FOR THE CASE WHEN TEMP2 LIES OUTSIDE TABLE, BUT
  1489. C     WITHIN THE TOLERANCE RANGE **
  1490. C
  1491.       IF(RATIO.GT.1.0) RATIO=1.0
  1492.       IF(RATIO.LT.0.0) RATIO=0.0
  1493. C
  1494.       DO 60 M=2,4
  1495.    60 PROP2(M-1)=PROP(L,M)+RATIO*(PROP(L+1,M)-PROP(L,M))
  1496. C
  1497. C        3. CALCULATE ELASTIC PROPERTIES AT END OF STEP
  1498. C
  1499.       YM2=PROP2(1)
  1500.       PV2=PROP2(2)
  1501.       A2=YM2/(1.+PV2)
  1502.       C2=0.5*A2
  1503.       A2=A2/(1.-2.*PV2)
  1504.       B2=A2*PV2
  1505.       A2=A2*(1.-PV2)
  1506. C
  1507. C        4. CALCULATE THERMAL STRAINS AT END OF STEP
  1508. C
  1509.    80 EPST(1)=PROP2(3)*(TEMP2-TREF)
  1510.       EPST(2)=EPST(1)
  1511.       EPST(3)=EPST(1)
  1512.       EPST(4)=0.0
  1513.       EPST(5)=0.0
  1514.       EPST(6)=0.0
  1515. C
  1516. C        5. CALCULATE STRESSES
  1517. C
  1518.       STRESS(1)=A2*(STRAIN(1)-EPST(1))+B2*(STRAIN(2)+STRAIN(3)-
  1519.      1          EPST(2)-EPST(3))
  1520.       STRESS(2)=A2*(STRAIN(2)-EPST(2))+B2*(STRAIN(1)+STRAIN(3)
  1521.      1          -EPST(1)-EPST(3))
  1522.       STRESS(3)=A2*(STRAIN(3)-EPST(3))+B2*(STRAIN(1)+STRAIN(2)
  1523.      1          -EPST(1)-EPST(2))
  1524.       STRESS(4)=C2*STRAIN(4)
  1525.       STRESS(5)=C2*STRAIN(5)
  1526.       STRESS(6)=C2*STRAIN(6)
  1527. C
  1528. C        6. CHECK FOR PRINTING
  1529. C
  1530.    90 IF(KPRI.EQ.0) GO TO 190
  1531. C
  1532. C        7. CHECK FOR EQUILIBRIUM ITERATION
  1533. C
  1534.       IF(ICOUNT.EQ.3) RETURN
  1535. C
  1536. C        8. CALCULATE CONSTITUTIVE LAW USING TEMPERATURES AT
  1537. C           END OF STEP
  1538. C
  1539.       DO 115 I=1,6
  1540.       DO 115 J=1,6
  1541.   115 C(I,J)=0.0
  1542. C
  1543.       C(1,1)=A2
  1544.       C(1,2)=B2
  1545.       C(1,3)=B2
  1546.       C(2,1)=B2
  1547.       C(2,2)=A2
  1548.       C(2,3)=B2
  1549.       C(3,1)=B2
  1550.       C(3,2)=B2
  1551.       C(3,3)=A2
  1552.       C(4,4)=C2
  1553.       C(5,5)=C2
  1554.       C(6,6)=C2
  1555.       RETURN
  1556. C
  1557. C        9. PRINTING OF STRESSES
  1558. C
  1559. C
  1560.   190 IF(INDNL.NE.2) GO TO 200
  1561. C
  1562. C     IN TOTAL LAGRANGIAN FORMULATION, CALCULATE CAUCHY STRESSES **
  1563. C
  1564.       CALL CAUCH3
  1565. C
  1566.   200 IF (IPRI.NE.0) RETURN
  1567.       IF (NG.NE.NGLAST) GO TO 202
  1568.       IF(NEL.GT.NELAST) GO TO 206
  1569.       IF(IPT-1) 210,208,210
  1570. C
  1571.   202 NGLAST=NG
  1572.   208 WRITE(6,2002)
  1573.   206 NELAST=NEL
  1574.       WRITE(6,2004) NEL
  1575.   210 WRITE(6,2005) IPT,(STRESS(J),J=1,6)
  1576.       WRITE(6,2009) TEMP2
  1577. C
  1578.  2002 FORMAT(8H ELEMENT,4X,6HOUTPUT,/,2X,6HNUMBER,2X,8HLOCATION,7X,
  1579.      1        8HSIGMA-X1,7X,8HSIGMA-X2,7X,8HSIGMA-X3,8X,7HTAU-X12,8X,
  1580.      2        7HTAU-X13,8X,7HTAU-X23,/,1X)
  1581.  2004 FORMAT(I4,/)
  1582.  2005 FORMAT(13X,I2,7X,6(E14.6,1X))
  1583.  2008 FORMAT(92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PROPER
  1584.      1TY TEMPERATURES   (SUBROUTINE THEL3))
  1585.  2009 FORMAT(14X,14HTEMPERATURE = ,E14.6,/)
  1586. C
  1587.       RETURN
  1588. C
  1589.       END
  1590. C *CDC*  *DECK OVL43
  1591. C *CDC*       OVERLAY (ADINA,4,3)
  1592. C *CDC* *DECK ELT3D6
  1593. C *UNI* )FOR,IS  N.ELT3D6, R.ELT3D6
  1594. C *CDC*       PROGRAM ELT3D6
  1595.       SUBROUTINE ELT3D6
  1596.       IMPLICIT REAL*8 (A-H,O-Z)
  1597. C
  1598. C     M O D E L     =     6
  1599. C
  1600.       RETURN
  1601.       END
  1602. C *CDC* *DECK OVL44
  1603. C *CDC*       OVERLAY (ADINA,4,4)
  1604. C *CDC* *DECK ELT3D7
  1605. C *UNI* )FOR,IS  N.ELT3D7, R.ELT3D7
  1606. C *CDC*       PROGRAM ELT3D7
  1607.       SUBROUTINE ELT3D7
  1608. C
  1609. C     M O D E L  =  7
  1610. C
  1611. C     E L A S T O P L A S T I C  M O D E L  (DRUCKER-PRAGER WITH
  1612. C     HARDENING CAP AND TENSION CUTOFF)
  1613. C
  1614.       IMPLICIT REAL*8 (A-H,O-Z)
  1615.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  1616.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  1617.       COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
  1618.      1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
  1619.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  1620.       COMMON /DPR/ ITWO
  1621.       COMMON A(1)
  1622. C
  1623.       REAL A
  1624.       DIMENSION IA(1)
  1625.       EQUIVALENCE (NPAR(10),NINT),(A(1),IA(1)),(NPAR(11),NINTZ)
  1626. C
  1627. C     FOR ADDRESSES N101,N102,N103,...  SEE SUBROUTINE THREDM
  1628. C
  1629. C
  1630.       IDW=14*ITWO
  1631.       NPT=NINT*NINT*NINTZ
  1632.       MATP=IA(N107 + NEL - 1)
  1633.       NM=N111 + (MATP-1)*8*ITWO
  1634.       IF(IND.NE.0) GO TO 100
  1635. C
  1636. C     INITIALIZE WORKING ARRAY
  1637. C
  1638.       NN=N112 + (NEL-1)*NPT*IDW
  1639. C
  1640.       CALL IDRK3(A(NN),A(NN),A(NM),NPT,IDW)
  1641. C
  1642.       GO TO 500
  1643. C
  1644. C     FIND MATERIAL LAW AND STRESSES
  1645. C
  1646.   100 NS=N112 + ((NEL-1)*NPT + (IPT-1))*IDW
  1647.       NS1=NS + 6*ITWO
  1648.       NS2=NS + 12*ITWO
  1649.       NS3=NS + 13*ITWO
  1650.       CALL DRUCK3(A(NM), A(NS), A(NS1), A(NS2), A(NS3))
  1651.   500 CONTINUE
  1652. C
  1653.       RETURN
  1654.       END
  1655. C *CDC* *DECK IDRK3
  1656. C *UNI* )FOR,IS  N.IDRK3, R.IDRK3
  1657.       SUBROUTINE IDRK3(WA,IWA,PROP,NPT,IDW)
  1658. C
  1659.       IMPLICIT REAL*8 (A-H,O-Z)
  1660.       COMMON /DPR/ ITWO
  1661.       DIMENSION WA(14,1),IWA(IDW,1),PROP(1)
  1662. C
  1663. C
  1664.       DO 25 J=1,NPT
  1665. C
  1666. C     SET INITIAL STRESSES AND STRAINS EQUAL TO ZERO
  1667. C
  1668.       DO 15 I=1,12
  1669.       WA(I,J)=0.0
  1670.    15 CONTINUE
  1671. C
  1672. C     SET INITIAL CAP POSITION
  1673. C
  1674.       WA(13,J)=PROP(8)
  1675. C
  1676. C     SET INITIAL STRESS STATE TO ELASTIC
  1677. C
  1678.       KJ=13*ITWO + 1
  1679.       IWA(KJ,J)=1
  1680. C
  1681.    25 CONTINUE
  1682. C
  1683.       RETURN
  1684.       END
  1685. C *CDC* *DECK DRUCK3
  1686. C *UNI* )FOR,IS  N.DRUCK3, R.DRUCK3
  1687.       SUBROUTINE DRUCK3(PROP,SIG,EPS,XI1A,IPEL)
  1688. C
  1689. C
  1690. C
  1691. C
  1692. C     SIG     STRESSES AT THE END OF THE PREVIOUS UPDATE
  1693. C     EPS     STRAINS AT THE END OF THE PREVIOUS UPDATE
  1694. C     RATIO   PART OF THE STRAIN INCREMENT TAKEN ELASTICALLY
  1695. C     DELEPS  INCREMENT IN STRAINS
  1696. C     DELSIG  INCREMENT IN STRESSES, ASSUMING ELASTIC BEHAVIOR
  1697. C     STRESS  CURRENT STRESSES
  1698. C     STRAIN  CURRENT STRAINS
  1699. C     EPSP    CURRENT PLASTIC STRAINS
  1700. C     XI1A    CAP POSITION
  1701. C
  1702. C
  1703. C     PROP(1)  YOUNGS MODULUS
  1704. C     PROP(2)  POISSONS RATIO
  1705. C     PROP(3)  DRUCKER-PRAGER YIELD FUNCTION PARAMETER (ALPHA)
  1706. C     PROP(4)  DRUCKER-PRAGER YIELD FUNCTION PARAMETER (K)
  1707. C     PROP(5)  CAP HARDENING CONSTANT (W)
  1708. C     PROP(6)  CAP HARDENING CONSTANT (D)
  1709. C     PROP(7)  TENSION CUTOFF LIMIT (T)
  1710. C     PROP(8)  INITIAL CAP POSITION
  1711. C
  1712. C
  1713. C     IPEL = 1, ELASTIC
  1714. C          = 2, PLASTIC (DRUCKER-PRAGER)
  1715. C          = 3, PLASTIC (SPECIAL CASE WHEN DRUCKER-PRAGER IS AT VERTEX)
  1716. C          = 4, PLASTIC (VERTEX)
  1717. C          = 5, PLASTIC (CAP)
  1718. C          = 6, TENSION CUTOFF LIMIT
  1719. C
  1720. C
  1721. C
  1722. C
  1723.       IMPLICIT REAL*8 (A-H,O-Z)
  1724.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  1725.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  1726.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  1727.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  1728.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  1729.       COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
  1730. C
  1731.       DIMENSION PROP(1),SIG(1),EPS(1),SS(6),DSS(6)
  1732.       DIMENSION DELSIG(6),DELEPS(6),DEPS(6),STATE(2),SS1(6),TEPS(6)
  1733.       DIMENSION EPSP(6)
  1734. C
  1735.       EQUIVALENCE (NPAR(3),INDNL),(DELEPS(1),DEPS(1)),(SS1(1),SS(1))
  1736.       DATA STATE /2H E,2H*P/
  1737. C
  1738.       XI1AD=XI1A
  1739.       IPELD=IPEL
  1740.       IF(IPT.NE.1) GO TO 110
  1741. C
  1742. C        1. CALCULATE MATERIAL CONSTANTS
  1743. C
  1744.       YM=PROP(1)
  1745.       PV=PROP(2)
  1746.       BM=YM/(1.0 - 2.0*PV)/3.0
  1747.       G=YM/(1.0 + PV)/2.0
  1748.       A1=BM + 4.0*G/3.0
  1749.       B1=BM - 2.0*G/3.0
  1750.       B3=1.0/(3.0*BM)
  1751.       C1=G
  1752. C
  1753.       A1I=1.0/YM
  1754.       B1I=-PV/YM
  1755.       C1I=1.0/C1
  1756. C
  1757.       ALFA=PROP(3)
  1758.       XK=PROP(4)
  1759.       WC=PROP(5)
  1760.       DC=PROP(6)
  1761.       TCUT=PROP(7)
  1762.       IF(TCUT.GE.(XK/ALFA)) TCUT=0.99*XK/ALFA
  1763. C
  1764. C        2. CALCULATE STRAIN INCREMENT, INITIALIZE TEPS(I)
  1765. C
  1766.   110 DO 120 I=1,6
  1767.       TEPS(I)=EPS(I)
  1768.   120 DELEPS(I)=STRAIN(I)-EPS(I)
  1769. C
  1770. C        3. CALCULATE THE STRESS INCREMENT,
  1771. C           ASSUMING ELASTIC BEHAVIOR
  1772. C
  1773.       DELSIG(1)=A1*DELEPS(1) + B1*(DELEPS(2) + DELEPS(3))
  1774.       DELSIG(2)=A1*DELEPS(2) + B1*(DELEPS(1) + DELEPS(3))
  1775.       DELSIG(3)=A1*DELEPS(3) + B1*(DELEPS(1) + DELEPS(2))
  1776.       DELSIG(4)=C1*DELEPS(4)
  1777.       DELSIG(5)=C1*DELEPS(5)
  1778.       DELSIG(6)=C1*DELEPS(6)
  1779. C
  1780. C        4. CALCULATE TOTAL STRESSES AND INVARIANTS,
  1781. C           ASSUMING ELASTIC BEHAVIOR
  1782. C
  1783.   150 DO 160 I=1,6
  1784.   160 STRESS(I)=SIG(I) + DELSIG(I)
  1785.       CALL DEVST3(SIG,SS1,XI11,XJ21)
  1786.       CALL DEVST3(STRESS,DSS,XI12,XJ22)
  1787.       DXI1=XI12 - XI11
  1788.       DO 165 J=1,6
  1789.   165 DSS(J)=DSS(J) - SS1(J)
  1790.       SX=SS1(1)
  1791.       SY=SS1(2)
  1792.       SZ=SS1(3)
  1793.       SXZ=SS1(5)
  1794.       SXY=SS1(4)
  1795.       SYZ=SS1(6)
  1796.       DX=DSS(1)
  1797.       DY=DSS(2)
  1798.       DZ=DSS(3)
  1799.       DXY=DSS(4)
  1800.       DXZ=DSS(5)
  1801.       DYZ=DSS(6)
  1802. C
  1803. C        5. CHECK IF ELASTIC STATE OF STRESS LIES
  1804. C           OUTSIDE YIELD SURFACE
  1805. C
  1806.       IF(XI12.GE.TCUT) GO TO 170
  1807.       IF(XI12.LT.XI1AD) GO TO 190
  1808.       GO TO 180
  1809. C
  1810. C     ELASTIC STRESS STATE EXCEEDS TENSION CUTOFF LIMIT
  1811. C     CHECK FOR TENSION CUTOFF OR DRUCKER-PRAGER YIELDING **
  1812. C
  1813.   170 IF(DXI1.EQ.0.0) GO TO 175
  1814.       FT1=(TCUT - XI11)/DXI1
  1815.       FT2=FT1*FT1
  1816.       FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + (DXY*DXY + DXZ*DXZ + DYZ*DYZ)
  1817.       FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
  1818.       FT=DSQRT(XJ21 + FT2*FT3 + FT1*FT4) + ALFA*TCUT - XK
  1819. C
  1820.       IF(FT) 175,175,176
  1821. C
  1822. C     TENSION CUTOFF *
  1823. C
  1824.   175 ICHK=6
  1825.       GO TO 210
  1826. C
  1827. C     DRUCKER-PRAGER YIELDING *
  1828. C
  1829.   176 ICHK=2
  1830.       GO TO 210
  1831. C
  1832. C     CHECK FOR DRUCKER-PRAGER YIELDING **
  1833. C
  1834.   180 FT=ALFA*XI12 + DSQRT(XJ22) - XK
  1835.       FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + (DXY*DXY + DXZ*DXZ + DYZ*DYZ)
  1836.       FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
  1837.       IF(FT) 200,200,185
  1838. C
  1839.   185 ICHK=2
  1840.       FTOLD=ALFA*XI11 + DSQRT(XJ21) - XK
  1841.       IF(XI11.EQ.XI1AD.AND.DXI1.EQ.0.0) ICHK=3
  1842.       IF(XI11.EQ.XI1AD.AND.FTOLD.EQ.3.0) ICHK=3
  1843.       GO TO 210
  1844. C
  1845. C     CHECK FOR DRUCKER-PRAGER YIELDING, VERTEX YIELDING,
  1846. C     OR CAP YIELDING **
  1847. C
  1848.   190 FT1=(XI1AD - XI11)/DXI1
  1849.       FT2=FT1*FT1
  1850.       FT3=0.5*(DX*DX + DY*DY + DZ*DZ) + (DXY*DXY + DXZ*DXZ + DYZ*DYZ)
  1851.       FT4=SX*DX + SY*DY + SZ*DZ + 2.0*(SXY*DXY + SXZ*DXZ + SYZ*DYZ)
  1852.       FT=DSQRT(XJ21 + FT2*FT3 + FT1*FT4) + ALFA*XI1AD - XK
  1853. C
  1854.       IF(FT) 192,194,196
  1855. C
  1856. C     CAP YIELDING *
  1857. C
  1858.   192 ICHK=5
  1859.       GO TO 210
  1860. C
  1861. C     VERTEX YIELDING (ADDITIONAL CHECK IS MADE LATER) *
  1862. C
  1863.   194 ICHK=3
  1864.       GO TO 210
  1865. C
  1866. C     DRUCKER-PRAGER YIELDING *
  1867. C
  1868.   196 ICHK=2
  1869.       GO TO 210
  1870. C
  1871. C     ELASTIC STRESS STATE IS WITHIN THE YIELD SURFACE AND
  1872. C     DOES NOT EXCEED TENSION CUTOFF **
  1873. C
  1874.   200 IPELD=1
  1875.       GO TO 700
  1876. C
  1877. C        6. ELASTIC STRESS STATE LIES OUTSIDE THE YIELD SURFACE
  1878. C           OR EXCEEDS TENSION CUTOFF---ADDITIONAL
  1879. C           STRESS CALCULATIONS ARE REQUIRED
  1880. C
  1881. C     CALCULATE THE FRACTION OF THE STRAIN INCREMENT OVER WHICH
  1882. C     THE MATERIAL RESPONSE IS ELASTIC **
  1883. C
  1884.   210 GO TO(200,220,250,250,250,260), ICHK
  1885. C
  1886. C     DRUCKER-PRAGER YIELDING *
  1887. C
  1888.   220 IF(IPELD.LT.2.OR.IPELD.GT.4) GO TO 230
  1889. C
  1890. C     STRESS STATE AT TIME OF LAST UPDATE IS ON  THE DRUCKER-PRAGER
  1891. C     YIELD SURFACE
  1892. C
  1893.       IPELD=2
  1894.       A=(2.0*ALFA*XK*DXI1) - (2.0*ALFA*ALFA*XI11*DXI1) + FT4
  1895.       RATIO=0.0
  1896.       IF(A) 225,300,300
  1897. C
  1898.   225 RATIO=-A/(FT3 - ALFA*ALFA*DXI1*DXI1)
  1899.       GO TO 300
  1900. C
  1901. C     STRESS STATE AT TIME OF LAST UPDATE IS NOT ON THE DRUCKER-PRAGER
  1902. C     YIELD SURFACE
  1903. C
  1904.   230 IPELD=2
  1905.       A=FT3 - ALFA*ALFA*DXI1*DXI1
  1906.       IF(A) 234,232,234
  1907. C
  1908.   232 RATIO=-(XJ21 - XK*XK + 2.0*ALFA*XK*XI11 - ALFA*ALFA*XI11*XI11)
  1909.      1      /(FT4 + 2.0*ALFA*XK*DXI1 - 2.0*ALFA*ALFA*XI11*DXI1)
  1910.       GO TO 300
  1911. C
  1912.   234 B=FT4 + 2.0*ALFA*XK*DXI1 - 2.0*ALFA*ALFA*XI11*DXI1
  1913.       CC=XJ21 - XK*XK + 2.0*ALFA*XK*XI11 - ALFA*ALFA*XI11*XI11
  1914.       RATIO=(-B + DSQRT(B*B - 4.0*A*CC))/(2.0*A)
  1915.       IF(A.GT.0.0) GO TO 300
  1916. C
  1917.       RATIO1=RATIO
  1918.       RATIO2=(-B - DSQRT(B*B - 4.0*A*CC))/(2.0*A)
  1919. C
  1920. C     DETERMINE THE CORRECT VALUE TO USE FOR RATIO
  1921. C
  1922.       KEY1=0
  1923.       KEY2=0
  1924.       ICNT=0
  1925.       XLIM=TCUT
  1926. C
  1927.   235 IF(RATIO1.GE.0.0.AND.RATIO1.LE.1.0) KEY1=1
  1928.       IF(RATIO2.GE.0.0.AND.RATIO2.LE.1.0) KEY2=1
  1929.       IF((KEY1 + KEY2).GE.1) GO TO 238
  1930.       IF(ICNT.EQ.0) GO TO 236
  1931.       WRITE(6,3004)
  1932.       STOP
  1933. C
  1934. C     CHECK IF RATIO1 AND/OR RATIO2 LIE WITHIN THE TOLERANCE RANGE
  1935. C
  1936.   236 IF(DABS(RATIO1).LT.1.0D-6) RATIO1=0.0
  1937.       IF(DABS(RATIO2).LT.1.0D-6) RATIO2=0.0
  1938.       IF(DABS(RATIO1 - 1.0).LT.1.0D-6) RATIO1=1.0
  1939.       IF(DABS(RATIO2 - 1.0).LT.1.0D-6) RATIO2=1.0
  1940. C
  1941. C     RECHECK VALUES OF RATIO1 AND RATIO2
  1942. C
  1943.       ICNT=ICNT + 1
  1944.       GO TO 235
  1945. C
  1946.   238 XINT1=XI11 + RATIO1*DXI1
  1947.       XINT2=XI11 + RATIO2*DXI1
  1948.       IF(XINT1.LE.XLIM.AND.XINT1.GE.XI1AD) KEY1=KEY1 + 1
  1949.       IF(XINT2.LE.XLIM.AND.XINT2.GE.XI1AD) KEY2=KEY2 + 1
  1950. C
  1951.       IF((KEY1 + KEY2).GT.3.OR.(KEY1 + KEY2).LT.2) GO TO 240
  1952.       IF(KEY1.EQ.1.AND.KEY2.EQ.1) GO TO 240
  1953.       GO TO 245
  1954. C
  1955.   240 WRITE(6,3005)
  1956.       STOP
  1957. C
  1958.   245 IF(KEY1.EQ.2) RATIO=RATIO1
  1959.       IF(KEY2.EQ.2) RATIO=RATIO2
  1960.       GO TO 300
  1961. C
  1962. C     VERTEX YIELDING OR CAP YIELDING *
  1963. C
  1964.   250 RATIO=(XI1AD - XI11)/DXI1
  1965.       IF(ICHK.EQ.5) IPELD=5
  1966.       GO TO 300
  1967. C
  1968. C     TENSION CUTOFF *
  1969. C
  1970.   260 IPELD=6
  1971.       STRESS(1)=TCUT/3.0
  1972.       STRESS(2)=TCUT/3.0
  1973.       STRESS(3)=TCUT/3.0
  1974.       STRESS(4)=0.0
  1975.       STRESS(5)=0.0
  1976.       STRESS(6)=0.0
  1977.       GO TO 700
  1978. C
  1979. C        7. UPDATE STRESS(I) AND TEPS(I) TO
  1980. C           THE START OF YIELDING
  1981. C
  1982.   300 DO 310 J=1,6
  1983.   310 STRESS(J)=SIG(J) + RATIO*DELSIG(J)
  1984. C
  1985.       DO 315 J=1,6
  1986.   315 TEPS(J)=EPS(J) + RATIO*DELEPS(J)
  1987. C
  1988. C        8. DETERMINE TYPE OF VERTEX YIELDING,
  1989. C           IF NECESSARY
  1990. C
  1991.       IF(ICHK.NE.3) GO TO 350
  1992.       DVSTR=DELEPS(1) + DELEPS(2) + DELEPS(3)
  1993.       CALL DEVST3(STRESS,SS,XI1,XJ2)
  1994.       SX=SS(1)
  1995.       SY=SS(2)
  1996.       SZ=SS(3)
  1997.       SXY=SS(4)
  1998.       SXZ=SS(5)
  1999.       SYZ=SS(6)
  2000. C
  2001.       XLMDP=ALFA*3.0*BM*DVSTR + (G/XJ2)*(SX*DELEPS(1) + SY*DELEPS(2)
  2002.      1      + SZ*DELEPS(3) + SXY*DELEPS(4) + SXZ*DELEPS(5) +
  2003.      2      SYZ*DELEPS(6))
  2004.       XLMC=-3.0*BM*DVSTR
  2005.       XDUM=3.0*ALFA*XLMDP
  2006.       IF(XLMDP.GT.0.0) GO TO 325
  2007.   320 IPELD=5
  2008.       GO TO 350
  2009.   325 IF(XLMC.GT.0.0) GO TO 330
  2010.       IPELD=2
  2011.       IF(DVSTR.EQ.XDUM) IPELD=3
  2012.       GO TO 350
  2013.   330 IPELD=4
  2014. C
  2015. C        9. ELASTIC-PLASTIC STRESS CALCULATIONS
  2016. C
  2017. C
  2018. C     DETERMINE SUBDIVISION FOR NUMERICAL INTEGRATION OF
  2019. C     THE STRESS-STRAIN LAW **
  2020. C
  2021.   350 M=25
  2022.       XM=(1.0 - RATIO)/DBLE(FLOAT(M))
  2023. C
  2024. C     SUBDIVIDE STRAIN INCREMENT **
  2025. C
  2026.       DO 355 I=1,6
  2027.   355 DEPS(I)=XM*DELEPS(I)
  2028. C
  2029. C     START OF STRESS CALCULATION LOOP **
  2030. C
  2031.       DO 600 INDEX=1,M
  2032. C
  2033. C     CHECK LOCATION OF CURRENT STATE OF STRESS **
  2034. C
  2035.       GO TO (420,420,420,450,450), IPELD
  2036. C
  2037. C     DRUCKER-PRAGER (INCLUDING DRUCKER-PRAGER AT VERTEX, IPEL=2,3) **
  2038. C
  2039.   420 CALL PRAG3(DEPS,IPELD)
  2040. C
  2041.   422 DO 425 I=1,6
  2042.       DO 425 J=1,6
  2043.   425 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
  2044. C
  2045. C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
  2046. C
  2047.       CALL DEVST3(STRESS,SS,XI1,XJ2)
  2048.       SX=SS(1)
  2049.       SY=SS(2)
  2050.       SZ=SS(3)
  2051.       SXY=SS(4)
  2052.       SXZ=SS(5)
  2053.       SYZ=SS(6)
  2054.       FT=ALFA*XI1 + DSQRT(XJ2) - XK
  2055.       IF(DABS(FT).LE.1.0D-6) GO TO 430
  2056.       GAMMA=(XK - ALFA*XI1)/DSQRT(XJ2)
  2057. C
  2058.       STRESS(1)=GAMMA*SX + XI1/3.0
  2059.       STRESS(2)=GAMMA*SY + XI1/3.0
  2060.       STRESS(3)=GAMMA*SZ + XI1/3.0
  2061.       STRESS(4)=GAMMA*SXY
  2062.       STRESS(5)=GAMMA*SXZ
  2063.       STRESS(6)=GAMMA*SYZ
  2064. C
  2065.       XI1=STRESS(1) + STRESS(2) + STRESS(3)
  2066. C
  2067. C     UPDATE TEPS(I) *
  2068. C
  2069.   430 DO 432 I=1,6
  2070.   432 TEPS(I)=TEPS(I) + DEPS(I)
  2071. C
  2072. C     CHECK FOR TENSION CUTOFF *
  2073. C
  2074.       IF(XI1.LT.TCUT) GO TO 435
  2075.       IPELD=6
  2076.       STRESS(1)=TCUT/3.0
  2077.       STRESS(2)=TCUT/3.0
  2078.       STRESS(3)=TCUT/3.0
  2079.       STRESS(4)=0.0
  2080.       STRESS(5)=0.0
  2081.       STRESS(6)=0.0
  2082.       GO TO 700
  2083. C
  2084. C     CALCULATE VOLUMETRIC PLASTIC STRAIN  (TOTAL AND INCREMENT)
  2085. C     UPDATE CAP POSITION *
  2086. C
  2087.   435 IF(IPELD.EQ.3) GO TO 442
  2088.       CALL DEVST3(STRESS,SS,DUM1,XJ2)
  2089.       SX=SS(1)
  2090.       SY=SS(2)
  2091.       SZ=SS(3)
  2092.       SXY=SS(4)
  2093.       SXZ=SS(5)
  2094.       SYZ=SS(6)
  2095.       AA=(9.0*BM*ALFA*ALFA)/(9.0*BM*ALFA*ALFA + G)
  2096.       BB=(3.0*ALFA*G)/DSQRT(XJ2)/(9.0*BM*ALFA*ALFA + G)
  2097.       DVPSTR=AA*(DEPS(1) + DEPS(2) + DEPS(3)) + BB*(SX*DEPS(1) +
  2098.      1       SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5)
  2099.      2       + SYZ*DEPS(6))
  2100.       VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
  2101.      1      + STRESS(3))
  2102. C
  2103.       XI1AD=XI1AD + (1.0/(DC*(WC - VPSTR)))*DVPSTR
  2104. C
  2105. C     CHECK CAP POSITION AND RESET, IF NECESSARY *
  2106. C
  2107.   440 IF(XI1.GE.XI1AD) GO TO 600
  2108.       IPELD=3
  2109.   442 XI1AD=XI1
  2110.       GO TO 600
  2111. C
  2112. C     VERTEX (IPEL=4) OR CAP (IPEL=5) **
  2113. C
  2114.   450 VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
  2115.      1      + STRESS(3))
  2116. C
  2117.       IF(IPELD.EQ.4) CALL VERT3(DEPS,VPSTR)
  2118.       IF(IPELD.EQ.5) CALL CAP3(DEPS,VPSTR)
  2119. C
  2120.       DO 455 I=1,6
  2121.       DO 455 J=1,6
  2122.   455 STRESS(I)=STRESS(I) + C(I,J)*DEPS(J)
  2123. C
  2124. C     CORRECT STRESS STATE TO YIELD SURFACE, IF NECESSARY *
  2125. C
  2126.       CALL DEVST3(STRESS,SS,XI1,XJ2)
  2127.       SX=SS(1)
  2128.       SY=SS(2)
  2129.       SZ=SS(3)
  2130.       SXY=SS(4)
  2131.       SXZ=SS(5)
  2132.       SYZ=SS(6)
  2133.       FT=ALFA*XI1 + DSQRT(XJ2) - XK
  2134.       IF(IPELD.EQ.5) GO TO 460
  2135.       IF(DABS(FT).LE.1.0D-6) GO TO 465
  2136.       GO TO 462
  2137. C
  2138.   460 IF(FT.LE.1.0D-6) GO TO 465
  2139. C
  2140.   462 GAMMA=(XK-ALFA*XI1)/DSQRT(XJ2)
  2141.       STRESS(1)=GAMMA*SX + XI1/3.0
  2142.       STRESS(2)=GAMMA*SY + XI1/3.0
  2143.       STRESS(3)=GAMMA*SZ + XI1/3.0
  2144.       STRESS(4)=GAMMA*SXY
  2145.       STRESS(5)=GAMMA*SXZ
  2146.       STRESS(6)=GAMMA*SYZ
  2147.       XI1=STRESS(1) + STRESS(2) + STRESS(3)
  2148. C
  2149. C     UPDATE CAP POSITION *
  2150. C
  2151.   465 XI1AD=XI1
  2152. C
  2153. C     UPDATE TEPS(I) *
  2154. C
  2155.       DO 468 I=1,6
  2156.   468 TEPS(I)=TEPS(I) + DEPS(I)
  2157. C
  2158.   600 CONTINUE
  2159. C
  2160. C        10. PERMANENT UPDATING OF VARIABLES
  2161. C
  2162.   700 IF(IUPDT.NE.0) GO TO 730
  2163.       XI1A=XI1AD
  2164.       IPEL=IPELD
  2165.       DO 710 I=1,6
  2166.       SIG(I)=STRESS(I)
  2167.   710 EPS(I)=STRAIN(I)
  2168. C
  2169. C        11. CHECK FOR PRINTING OR EQUILIBRIUM ITERATION
  2170. C
  2171.   730 IF(KPRI.EQ.0) GO TO 800
  2172. C
  2173.       IF(ICOUNT.EQ.3) RETURN
  2174. C
  2175. C        12. FORM NEW MATERIAL LAW
  2176. C
  2177.       IF(IEQREF.EQ.1) GO TO 740
  2178.       GO TO (740,750,750,760,770,740), IPELD
  2179. C
  2180. C     ELASTIC (IPEL=1) OR TENSION CUTOFF (IPEL=6) **
  2181. C
  2182.   740 DO 745 I=1,6
  2183.       DO 745 J=1,6
  2184.   745 C(I,J)=0.0
  2185.       C(1,1)=A1
  2186.       C(1,2)=B1
  2187.       C(1,3)=B1
  2188.       C(2,1)=B1
  2189.       C(2,2)=A1
  2190.       C(2,3)=B1
  2191.       C(3,1)=B1
  2192.       C(3,2)=B1
  2193.       C(3,3)=A1
  2194.       C(4,4)=C1
  2195.       C(5,5)=C1
  2196.       C(6,6)=C1
  2197. C
  2198.       RETURN
  2199. C
  2200. C     DRUCKER-PRAGER (INCLUDING DRUCKER-PRAGER AT VERTEX, IPEL=2,3) **
  2201. C
  2202.   750 CALL PRAG3(DEPS,IPELD)
  2203. C
  2204.       RETURN
  2205. C
  2206. C     VERTEX (IPEL=4) **
  2207. C
  2208.   760 VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
  2209.      1       + STRESS(3))
  2210.       CALL VERT3(DEPS,VPSTR)
  2211. C
  2212.       RETURN
  2213. C
  2214. C     CAP (IPEL=5) **
  2215. C
  2216.   770 VPSTR=(TEPS(1) + TEPS(2) + TEPS(3)) - B3*(STRESS(1) + STRESS(2)
  2217.      1       + STRESS(3))
  2218.       CALL CAP3(DEPS,VPSTR)
  2219. C
  2220.       RETURN
  2221. C
  2222. C        13. PRINTING OF STRESSES AND STRAINS
  2223. C
  2224.   800 CALL DEVST3 (STRESS,SS,XI1,XJ2)
  2225.       FT=ALFA*XI1 + DSQRT(XJ2) - XK
  2226. C
  2227. C     CALCULATE PLASTIC STRAINS **
  2228. C
  2229.       EPSP(1)=STRAIN(1) - (A1I*STRESS(1) + B1I*(STRESS(2) + STRESS(3)))
  2230.       EPSP(2)=STRAIN(2) - (A1I*STRESS(2) + B1I*(STRESS(1) + STRESS(3)))
  2231.       EPSP(3)=STRAIN(3) - (A1I*STRESS(3) + B1I*(STRESS(1) + STRESS(2)))
  2232.       EPSP(4)=STRAIN(4) - C1I*STRESS(4)
  2233.       EPSP(5)=STRAIN(5) - C1I*STRESS(5)
  2234.       EPSP(6)=STRAIN(6) - C1I*STRESS(6)
  2235. C
  2236.   810 IF (IPRI.NE.0) RETURN
  2237.       IDUM=1
  2238.       IF(IPELD.GT.1.AND.IPELD.LT.6) IDUM=2
  2239.       IF (IPS.LT.0) GO TO 900
  2240. C
  2241. C     STRESS PRINTOUT ONLY **
  2242. C
  2243.       IF (IPT.GT.1) GO TO 850
  2244. C
  2245. C     PRINT HEADING *
  2246. C
  2247.       WRITE (6,2000)
  2248. C
  2249. C     PRINT ELEMENT NUMBER *
  2250. C
  2251.       WRITE (6,2005) NEL
  2252. C
  2253. C     PRINT INTEGRATION POINT STRESSES *
  2254. C
  2255.   850 WRITE (6,2100) IPT,STATE(IDUM),(STRESS(J),J=1,6)
  2256.       WRITE (6,2200) IPELD,XI1AD,FT
  2257. C
  2258.       RETURN
  2259. C
  2260. C     STRESS AND STRAIN PRINTOUT **
  2261. C
  2262.   900 IF (IPT.GT.1) GO TO 920
  2263. C
  2264. C     PRINT HEADING *
  2265. C
  2266.       WRITE (6,2000)
  2267. C
  2268. C     PRINT ELEMENT NUMBER *
  2269. C
  2270.       WRITE (6,2005) NEL
  2271. C
  2272. C     PRINT INTEGRATION POINT STRESSES AND STRAINS *
  2273. C
  2274.   920 WRITE (6,2100) IPT,STATE(IDUM),(STRESS(J),J=1,6)
  2275.       WRITE (6,2400) (STRAIN(J),J=1,6)
  2276.       WRITE (6,2500) (EPSP(J),J=1,6)
  2277.       WRITE (6,2200) IPELD,XI1AD,FT
  2278. C
  2279.       RETURN
  2280. C
  2281.  2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,
  2282.      1        13X,2HYY,13X,2HZZ,13X,2HXY,13X,2HXZ,13X,2HYZ,/,
  2283.      2        1X,7HNUM/IPT,3X,5HSTATE,4X,10HCOMPONENTS)
  2284.  2005 FORMAT (/,1X,I3)
  2285.  2100 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,6(E14.6,1X))
  2286.  2200 FORMAT (20X,7HIPEL = ,I2,2X,15HCAP POSITION = ,E14.6,2X,
  2287.      1        21HD-P YIELD FUNCTION = ,E14.6,/)
  2288.  2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
  2289.  2500 FORMAT (25X,7HPLASTIC,3X,6(E14.6,1X))
  2290. C
  2291.  3004 FORMAT(87H   ERROR   UNABLE TO OBTAIN VALUE FOR "RATIO" BETWEEN 0.
  2292.      10 AND 1.0   (SUBROUTINE DRUCK3)/)
  2293.  3005 FORMAT(75H   ERROR   UNABLE TO OBTAIN CORRECT VALUE FOR "RATIO"
  2294.      1(SUBROUTINE DRUCK3)/)
  2295. C
  2296.       END
  2297. C *CDC* *DECK PRAG3
  2298. C *UNI* )FOR,IS N.PRAG3, R.PRAG3
  2299.       SUBROUTINE PRAG3(DEPS,IPELD)
  2300. C
  2301. C
  2302. C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
  2303. C     FOR THE DRUCKER-PRAGER YIELD SURFACE (IPEL=2,3)
  2304. C
  2305. C
  2306.       IMPLICIT REAL*8 (A-H,O-Z)
  2307.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  2308.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  2309.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  2310.       COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
  2311. C
  2312.       DIMENSION DP(36),SS(6),DEPS(1)
  2313.       EQUIVALENCE (C(1,1),DP(1))
  2314. C
  2315. C
  2316.       CALL DEVST3(STRESS,SS,DUM1,XJ2)
  2317.       SX=SS(1)
  2318.       SY=SS(2)
  2319.       SZ=SS(3)
  2320.       SXY=SS(4)
  2321.       SXZ=SS(5)
  2322.       SYZ=SS(6)
  2323. C
  2324.       QDQ=DSQRT(G + 9.0*BM*ALFA*ALFA)
  2325.       AA=G/DSQRT(XJ2)/QDQ
  2326.       BB=3.0*BM*ALFA/QDQ
  2327. C
  2328.       DLAMDA=BB*(DEPS(1) + DEPS(2) + DEPS(3)) + AA*(SX*DEPS(1) +
  2329.      1       SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5) +
  2330.      2       SYZ*DEPS(6))
  2331.       IF(DLAMDA.GT.0.0) GO TO 30
  2332. C
  2333.       SX=0.0
  2334.       SY=0.0
  2335.       SZ=0.0
  2336.       SXY=0.0
  2337.       SXZ=0.0
  2338.       SYZ=0.0
  2339.       GO TO 40
  2340. C
  2341.    30 IF(IPELD.NE.3) GO TO 35
  2342.       QDQ=DSQRT(G)
  2343.       AA=G/DSQRT(XJ2)/QDQ
  2344.       BB=0.0
  2345. C
  2346.    35 SX=AA*SX + BB
  2347.       SY=AA*SY + BB
  2348.       SZ=AA*SZ + BB
  2349.       SXY=AA*SXY
  2350.       SXZ=AA*SXZ
  2351.       SYZ=AA*SYZ
  2352. C
  2353.    40 DP(1)=A1 - SX*SX
  2354.       DP(2)=B1 - SX*SY
  2355.       DP(3)=B1 - SX*SZ
  2356.       DP(4)=   - SX*SXY
  2357.       DP(5)=   - SX*SXZ
  2358.       DP(6)=   - SX*SYZ
  2359. C
  2360.       DP(7)=DP(2)
  2361.       DP(8)=A1 - SY*SY
  2362.       DP(9)=B1 - SY*SZ
  2363.       DP(10)=   - SY*SXY
  2364.       DP(11)=   - SY*SXZ
  2365.       DP(12)=   - SY*SYZ
  2366. C
  2367.       DP(13)=DP(3)
  2368.       DP(14)=DP(9)
  2369.       DP(15)=A1 - SZ*SZ
  2370.       DP(16)=   - SZ*SXY
  2371.       DP(17)=   - SZ*SXZ
  2372.       DP(18)=   - SZ*SYZ
  2373. C
  2374.       DP(19)=DP(4)
  2375.       DP(20)=DP(10)
  2376.       DP(21)=DP(16)
  2377.       DP(22)=C1 - SXY*SXY
  2378.       DP(23)=   - SXY*SXZ
  2379.       DP(24)=   - SXY*SYZ
  2380. C
  2381.       DP(25)=DP(5)
  2382.       DP(26)=DP(11)
  2383.       DP(27)=DP(17)
  2384.       DP(28)=DP(23)
  2385.       DP(29)=C1 - SXZ*SXZ
  2386.       DP(30)=   - SXZ*SYZ
  2387. C
  2388.       DP(31)=DP(6)
  2389.       DP(32)=DP(12)
  2390.       DP(33)=DP(18)
  2391.       DP(34)=DP(24)
  2392.       DP(35)=DP(30)
  2393.       DP(36)=C1 - SYZ*SYZ
  2394. C
  2395.       RETURN
  2396.       END
  2397. C *CDC* *DECK VERT3
  2398. C *UNI* )FOR,IS  N.VERT3, R.VERT3
  2399.       SUBROUTINE VERT3(DEPS,VPSTR)
  2400. C
  2401. C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
  2402. C     FOR THE DRUCKER-PRAGER---CAP INTERSECTION  (VERTEX, IPEL=4)
  2403. C
  2404.       IMPLICIT REAL*8 (A-H,O-Z)
  2405.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  2406.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  2407.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  2408.       COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
  2409. C
  2410.       DIMENSION VP(36),SS(6),DEPS(1)
  2411.       EQUIVALENCE (C(1,1),VP(1))
  2412. C
  2413. C
  2414.       CALL DEVST3(STRESS,SS,DUM1,XJ2)
  2415.       SX=SS(1)
  2416.       SY=SS(2)
  2417.       SZ=SS(3)
  2418.       SXY=SS(4)
  2419.       SXZ=SS(5)
  2420.       SYZ=SS(6)
  2421. C
  2422.       QDQ=DSQRT(G + 9.0*BM*ALFA*ALFA)
  2423.       AA=G/XJ2/QDQ
  2424.       BB=3.0*BM*ALFA/QDQ
  2425.       CC=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC-VPSTR)))
  2426. C
  2427.       DLAMD=BB*(DEPS(1) + DEPS(2) + DEPS(3)) + AA*(SX*DEPS(1) +
  2428.      1      SY*DEPS(2) + SZ*DEPS(3) + SXY*DEPS(4) + SXZ*DEPS(5) +
  2429.      2      SYZ*DEPS(6))
  2430.       DLAMC=-DEPS(1) - DEPS(2) - DEPS(3)
  2431.       IF(DLAMD.GT.0.0.AND.DLAMC.GT.0.0) GO TO 30
  2432. C
  2433.       CC=0.0
  2434.       SX=0.0
  2435.       SY=0.0
  2436.       SZ=0.0
  2437.       SXY=0.0
  2438.       SXZ=0.0
  2439.       SYZ=0.0
  2440.       GO TO 35
  2441. C
  2442.    30 SX=AA*SX + BB
  2443.       SY=AA*SY + BB
  2444.       SZ=AA*SZ + BB
  2445.       SXY=AA*SXY
  2446.       SXZ=AA*SXZ
  2447.       SYZ=AA*SYZ
  2448. C
  2449.    35 VP(1)=A1 - SX*SX - CC
  2450.       VP(2)=B1 - SX*SY - CC
  2451.       VP(3)=B1 - SX*SZ - CC
  2452.       VP(4)=   - SX*SXY
  2453.       VP(5)=   - SX*SXZ
  2454.       VP(6)=   - SX*SYZ
  2455. C
  2456.       VP(7)=VP(2)
  2457.       VP(8)=A1 - SY*SY - CC
  2458.       VP(9)=B1 - SY*SZ - CC
  2459.       VP(10)=  -SY*SXY
  2460.       VP(11)=  -SY*SXZ
  2461.       VP(12)=  - SY*SYZ
  2462. C
  2463.       VP(13)=VP(3)
  2464.       VP(14)=VP(9)
  2465.       VP(15)=A1 - SZ*SZ - CC
  2466.       VP(16)=   - SZ*SXY
  2467.       VP(17)=   - SZ*SXZ
  2468.       VP(18)=   - SZ*SYZ
  2469. C
  2470.       VP(19)=VP(4)
  2471.       VP(20)=VP(10)
  2472.       VP(21)=VP(16)
  2473.       VP(22)=C1 - SXY*SXY
  2474.       VP(23)=   - SXY*SXZ
  2475.       VP(24)=   - SXY*SYZ
  2476. C
  2477.       VP(25)=VP(5)
  2478.       VP(26)=VP(11)
  2479.       VP(27)=VP(17)
  2480.       VP(28)=VP(23)
  2481.       VP(29)=C1 - SXZ*SXZ
  2482.       VP(30)=   - SXZ*SYZ
  2483. C
  2484.       VP(31)=VP(6)
  2485.       VP(32)=VP(12)
  2486.       VP(33)=VP(18)
  2487.       VP(34)=VP(24)
  2488.       VP(35)=VP(30)
  2489.       VP(36)=C1 - SYZ*SYZ
  2490. C
  2491.       RETURN
  2492.       END
  2493. C *CDC* *DECK CAP3
  2494. C *UNI* )FOR,IS N.CAP3, R,CAP3
  2495.       SUBROUTINE CAP3(DEPS,VPSTR)
  2496. C
  2497. C
  2498. C     THIS SUBROUTINE FORMS THE ELASTIC-PLASTIC MATERIAL LAW
  2499. C     FOR THE CAP (IPEL=5)
  2500. C
  2501. C
  2502.       IMPLICIT REAL*8 (A-H,O-Z)
  2503.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  2504.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  2505.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  2506.       COMMON /DRPR3/ A1,B1,C1,B3,G,BM,ALFA,XK,DC,WC,TCUT,A1I,B1I,C1I
  2507. C
  2508.       DIMENSION CP(36),DEPS(1)
  2509.       EQUIVALENCE (C(1,1),CP(1))
  2510. C
  2511. C
  2512.       GAMMA=(9.0*BM*BM)/((9.0*BM) + 3.0/(DC*(WC-VPSTR)))
  2513.       DLAMDA=-DEPS(1) - DEPS(2) - DEPS(3)
  2514.       IF(DLAMDA.GT.0.0) GO TO 30
  2515. C
  2516.       CP1=A1
  2517.       CP2=B1
  2518.       GO TO 35
  2519. C
  2520.    30 CP1=A1 - GAMMA
  2521.       CP2=B1 - GAMMA
  2522. C
  2523.    35 DO 40 J=1,36
  2524.    40 CP(J)=0.0
  2525. C
  2526.       CP(1)=CP1
  2527.       CP(2)=CP2
  2528.       CP(3)=CP2
  2529.       CP(7)=CP2
  2530.       CP(8)=CP1
  2531.       CP(9)=CP2
  2532.       CP(13)=CP2
  2533.       CP(14)=CP2
  2534.       CP(15)=CP1
  2535.       CP(22)=C1
  2536.       CP(29)=C1
  2537.       CP(36)=C1
  2538. C
  2539.       RETURN
  2540.       END
  2541. C *CDC* *DECK DEVST3
  2542. C *UNI* )FOR,IS  N.DEVST3, R.DEVST3
  2543.       SUBROUTINE DEVST3(STRESS,DSTRS,XI1,XJ2)
  2544. C
  2545. C
  2546. C     THIS SUBROUTINE CALCULATES THE FOLLOWING QUANTITIES-
  2547. C          1. DEVIATORIC STRESS TENSOR
  2548. C          2. ITS SECOND INVARIANT
  2549. C          3. FIRST INVARIANT OF THE STRESS TENSOR
  2550. C
  2551. C
  2552.       IMPLICIT REAL*8 (A-H,O-Z)
  2553.       DIMENSION STRESS(6),DSTRS(6)
  2554. C
  2555. C
  2556.       SM=STRESS(1) + STRESS(2) + STRESS(3)
  2557.       XI1=SM
  2558.       SM=SM/3.0
  2559. C
  2560.       DSTRS(1)=STRESS(1) - SM
  2561.       DSTRS(2)=STRESS(2) - SM
  2562.       DSTRS(3)=STRESS(3) - SM
  2563.       DSTRS(4)=STRESS(4)
  2564.       DSTRS(5)=STRESS(5)
  2565.       DSTRS(6)=STRESS(6)
  2566. C
  2567.       XJ2=0.5*(DSTRS(1)*DSTRS(1) + DSTRS(2)*DSTRS(2) +
  2568.      1    DSTRS(3)*DSTRS(3)) + (DSTRS(4)*DSTRS(4) + DSTRS(5)*DSTRS(5)
  2569.      2    + DSTRS(6)*DSTRS(6))
  2570. C
  2571.       RETURN
  2572.       END
  2573. C *CDC* *DECK OVL45
  2574. C *CDC*       OVERLAY (ADINA,4,5)
  2575. C *CDC* *DECK ELT3D8
  2576. C *UNI* )FOR,IS  N.ELT3D8, R.ELT3D8
  2577. C *CDC*       PROGRAM ELT3D8
  2578.       SUBROUTINE ELT3D8
  2579. C
  2580. C
  2581. C                M O D E L S = 8 AND 9
  2582. C
  2583. C
  2584.       IMPLICIT REAL*8 (A-H,O-Z)
  2585.       COMMON A(1)
  2586.       REAL A
  2587.       DIMENSION IA(1)
  2588.       EQUIVALENCE (A(1),IA(1))
  2589. C
  2590.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  2591.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  2592.       COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
  2593.      1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
  2594.       COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  2595.       COMMON /DPR/ ITWO
  2596. C
  2597.       EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ),(NPAR(17),NCON)
  2598. C
  2599.       IDW=21*ITWO
  2600.       NPT=NINT*NINT*NINTZ
  2601.       MATP=IA(N107 + NEL - 1)
  2602.       NM=N111 + (MATP - 1)*NCON*ITWO
  2603.       NN=N112 + (NEL-1) * NPT * IDW
  2604. C
  2605.       IF (IND.NE.0) GO TO 100
  2606. C
  2607. C     I N I T I A L I Z E   W O R K I N G   A R R A Y   (WA)
  2608. C
  2609.       CALL IELP3 (A(NN),A(NN),A(NM),NPT,IDW)
  2610.       GO TO 599
  2611. C
  2612. C     C A L C U L A T E   S T R E S S E S   A N D
  2613. C     S T R E S S  -  S T R A I N   L A W
  2614. C
  2615.   100 NS=NN + (IPT-1) * IDW
  2616.       CALL ELPAL3 (A(NM),A(NS),A(NS + 6*ITWO),A(NS + 12*ITWO),
  2617.      1             A(NS + 18*ITWO),A(NS + 19*ITWO),A(NS + 20*ITWO))
  2618.   599 CONTINUE
  2619.       RETURN
  2620.       END
  2621. C *CDC* *DECK IELP3
  2622. C *UNI* )FOR,IS  N.IELP3,  R.IELP3
  2623.       SUBROUTINE IELP3 (WA,IWA,PROP,NPT,IDW)
  2624. C
  2625.       IMPLICIT REAL*8 (A-H,O-Z)
  2626.       COMMON /DPR/ ITWO
  2627.       DIMENSION WA(21,1),IWA(IDW,1),PROP(1)
  2628. C
  2629.       DO 25 J=1,NPT
  2630. C
  2631.       DO 15 I=1,19
  2632.       WA(I,J)=0.
  2633.    15 CONTINUE
  2634. C
  2635.       WA(20,J)=(PROP(3)**2)/3.
  2636.       KJ=20*ITWO + 1
  2637.       IWA(KJ,J)=1
  2638. C
  2639.    25 CONTINUE
  2640. C
  2641.       RETURN
  2642.       END
  2643. C *CDC* *DECK ELPAL3
  2644. C *UNI* )FOR,IS  N.ELPAL3, R.ELPAL3
  2645.       SUBROUTINE ELPAL3 (PROP,SIG,EPS,ALFA,EPSTR,YIELD,IPEL)
  2646. C
  2647. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  2648. C .                                                                   .
  2649. C .   THIS SUBROUTINE CALCULATES THE STRESSES AND STRESS-STRAIN LAW   .
  2650. C .   FOR THE FOLLOWING 3-DIM MATERIAL MODELS -                       .
  2651. C .                                                                   .
  2652. C .      MODEL=9  (MOD=1)    ELASTIC-PLASTIC WITH KINEMATIC HARDENING .
  2653. C .      MODEL=8  (MOD=2)    ELASTIC-PLASTIC WITH ISOTROPIC HARDENING .
  2654. C .                                                                   .
  2655. C .      ELASTIC-PERFECTLY PLASTIC CAN BE HANDLED WITH EITHER MODEL   .
  2656. C .      BY SETTING THE HARDENING MODULUS TO ZERO.                    .
  2657. C .      HOWEVER, IF THE CALCULATED STRESSES FALL BEYOND THE TOLERATED.
  2658. C .      VALUE, MODEL=8 WILL APPLY A CORRECTION WHEREAS MODEL=9 WILL  .
  2659. C .      WILL NOT APPLY SUCH A CORRECTION.                            .
  2660. C .                                                                   .
  2661. C .      THE TOLERATED VALUE USED HERE IS THAT THE EQUIVALENT STRESS  .
  2662. C .      SHOULD BE WITHIN ONE-HALF PERCENT OF THE YIELD STRESS IN     .
  2663. C .      SIMPLE TENSION.                                              .
  2664. C .                                                                   .
  2665. C .                                                                   .
  2666. C .   THE FOLLOWING VARIABLES ARE USED IN THIS SUBROUTINE -           .
  2667. C .                                                                   .
  2668. C .      SIG     PREVIOUS STRESSES                                    .
  2669. C .      EPS     PREVIOUS STRAINS                                     .
  2670. C .                                                                   .
  2671. C .      STRESS  CURRENT STRESSES (TO BE CALCULATED)                  .
  2672. C .      STRAIN  CURRENT STRAINS  (G I V E N)                         .
  2673. C .              (STRAIN INCREMENT IN ULJ FORMULATION)                .
  2674. C .      EPSP    CURRENT PLASTIC STRAINS                              .
  2675. C .      EPSTR   ACCUMULATED EFFECTIVE PLASTIC STRAIN                 .
  2676. C .                                                                   .
  2677. C .      FTA     (CURRENT EQUIVALENT STRESS ** 2) / 3.                .
  2678. C .      YIELD   INITIALIZED TO (PROP(3)**2)/3.                       .
  2679. C .              UPDATED TO EQUAL FTA FOR ISOTROPIC HARDENING CASE    .
  2680. C .      FTB     = YIELD                                              .
  2681. C .                                                                   .
  2682. C .      IPEL    = 1, MATERIAL ELASTIC (INITIAL VALUE)                .
  2683. C .              = 2, MATERIAL PLASTIC                                .
  2684. C .                                                                   .
  2685. C .      ALFA    TRANSLATION OF YIELD SURFACE IN STRESS SPACE         .
  2686. C .      DEPS    STRAIN INCREMENT FOR EACH STEP OF INTEGRATION        .
  2687. C .      TEPS    TOTAL STRAINS ACCOUNTED FOR DURING INTEGRATION       .
  2688. C .                                                                   .
  2689. C .      DELEPS  INCREMENTAL STRAINS                                  .
  2690. C        DELSIG  INCREMENTAL STRESSES, CALCULATED ON THE ASSUMPTION   .
  2691. C .              OF ELASTIC BEHAVIOR DURING STRAIN INCREMENT (DELEPS) .
  2692. C .                                                                   .
  2693. C .      ICOR    NO. OF TIMES CORRECTION IS APPLIED (APPLICABLE       .
  2694. C .              ONLY FOR THE PERFECTLY PLASTIC CASE)                 .
  2695. C .      INTER   NO. OF INCREMENT INTERVALS  (MAX=25)                 .
  2696. C .                                                                   .
  2697. C .      PROP(1) YOUNGS MODULUS                                       .
  2698. C .      PROP(2) POISSONS RATIO                                       .
  2699. C .                                                                   .
  2700. C .      BILINEAR STRESS-STRAIN CURVE                                 .
  2701. C .                                                                   .
  2702. C .      PROP(3) INITIAL YIELD STRESS IN TENSION                      .
  2703. C .      PROP(4) HARDENING MODULUS                                    .
  2704. C .                                                                   .
  2705. C .      PIECEWISE-LINEAR STRESS-STRAIN CURVE                         .
  2706. C .                                                                   .
  2707. C .      PROP(3),PROP(4),...,PROP(NCON - 1),PROP(NCON) ARE THE        .
  2708. C .      PAIRS OF STRESS, STRAIN VALUES DEFINING THE PLASTIC          .
  2709. C .      PORTION OF THE STRESS-STRAIN CURVE (PROP(3) IS THE INITIAL   .
  2710. C .      YIELD STRESS IN SIMPLE TENSION)                              .
  2711. C .                                                                   .
  2712. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  2713. C
  2714.       IMPLICIT REAL*8 (A-H,O-Z)
  2715.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  2716.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  2717.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  2718.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  2719.       COMMON /MTMD3D/ D(36),STRESS(6),STRAIN(6),IPT,NEL,IPS
  2720.       COMMON /DISDR/ DISD(9)
  2721. C
  2722.       COMMON /MISES/ A1,B1,C1,A3,A1I,B1I,C1I,BET,CEE,DEPS(6),DEPSP(6),
  2723.      1               TEPS(6),ALFAD(6),HP,FTB,XCON1,XCON2,MOD
  2724.       COMMON /PSTCH/ STRCH(3),RDCS(3)
  2725. C
  2726.       DIMENSION DELSIG(6),DELEPS(6),STATE(2),IMODEL(2)
  2727.       DIMENSION PROP(1),SIG(1),EPS(1),ALFA(1),EPSP(6)
  2728. C
  2729.       EQUIVALENCE (NPAR(17),NCON)
  2730.       EQUIVALENCE (NPAR(15),MODEL),(NPAR(3),INDNL)
  2731.       DATA STATE /2H E,2H*P/, IMODEL /2, 1/
  2732. C
  2733. C
  2734.       YIELDD=YIELD
  2735.       IPELD=IPEL
  2736.       EPSTRD=EPSTR
  2737.       ICOR=0
  2738.       INTER=0
  2739. C
  2740.       DO 50 I=1,6
  2741.       EPSP(I)=0.0
  2742.    50 ALFAD(I)=ALFA(I)
  2743. C
  2744.       MOD=IMODEL(MODEL - 7)
  2745.       YM=PROP(1)
  2746.       PV=PROP(2)
  2747.       ET=PROP(4)
  2748.       ETOLD=ET
  2749. C
  2750.       IF(IPT .NE. 1) GO TO 80
  2751. C
  2752.       XCON1=2.0/3.0
  2753.       XCON2=1.0/3.0
  2754. C
  2755. C
  2756. C     .....  CALCULATION OF MATERIAL CONSTANTS   ......................
  2757. C
  2758.       A1=YM/(1.+PV)
  2759.       A3=A1
  2760.       C1=A1/2.
  2761.       A1=A1/(1.-2.*PV)
  2762.       B1=A1*PV
  2763.       A1=A1-B1
  2764. C
  2765.       A1I=1.0/YM
  2766.       B1I=-PV/YM
  2767.       C1I=1.0/C1
  2768. C
  2769. C
  2770.    80 IF (NCON.GE.6) GO TO 90
  2771. C
  2772. C     BILINEAR STRESS-STRAIN CURVE
  2773. C
  2774.       IF (IPT.NE.1) GO TO 85
  2775. C
  2776.       EET=YM*ET/(YM - ET)
  2777.       CEE=XCON1*EET
  2778.       HP=(A3*A3)/(CEE + A3)/2.
  2779.       FTB=YIELDD
  2780.       BET=HP/YIELDD
  2781.       GO TO 115
  2782. C
  2783.    85 IF(ET.EQ.0.0) GO TO 115
  2784.       FTB=YIELDD
  2785.       BET=HP/YIELDD
  2786.       GO TO 115
  2787. C
  2788. C     PIECEWISE-LINEAR STRESS-STRAIN CURVE
  2789. C
  2790.    90 CALL HARDM3 (PROP,EPSTRD,ET)
  2791.       EET=YM*ET/(YM - ET)
  2792.       CEE=XCON1*EET
  2793.       HP=(A3*A3)/(CEE + A3)/2.
  2794.       FTB=YIELDD
  2795.       BET=HP/YIELDD
  2796. C
  2797. C
  2798. C     .....  DETERMINATION OF STATE OF STRESS  ........................
  2799. C
  2800. C        1. CALCULATE INCREMENTAL TOTAL STRAINS AND CURRENT
  2801. C          PLASTIC STRAINS
  2802. C
  2803.   115 IF (INDNL.EQ.3) GO TO 121
  2804.       DO 120 I=1,6
  2805.   120 DELEPS(I)=STRAIN(I) - EPS(I)
  2806.       GO TO 130
  2807. C
  2808.   121 DO 122 I=1,6
  2809.   122 DELEPS(I)=STRAIN(I)
  2810.       GO TO 145
  2811. C
  2812.   130 EPSP(1)=EPS(1) - (A1I*SIG(1) + B1I*(SIG(2) + SIG(3)))
  2813.       EPSP(2)=EPS(2) - (A1I*SIG(2) + B1I*(SIG(1) + SIG(3)))
  2814.       EPSP(3)=EPS(3) - (A1I*SIG(3) + B1I*(SIG(1) + SIG(2)))
  2815.       EPSP(4)=EPS(4) - C1I*SIG(4)
  2816.       EPSP(5)=EPS(5) - C1I*SIG(5)
  2817.       EPSP(6)=EPS(6) - C1I*SIG(6)
  2818. C
  2819. C        2. CALCULATE INCREMENTAL STRESSES,
  2820. C           ASSUMING ELASTIC BEHAVIOR
  2821. C
  2822.   145 DELSIG(1)=A1*DELEPS(1) + B1*(DELEPS(2) + DELEPS(3))
  2823.       DELSIG(2)=A1*DELEPS(2) + B1*(DELEPS(1)+DELEPS(3))
  2824.       DELSIG(3)=A1*DELEPS(3) + B1*(DELEPS(1)+DELEPS(2))
  2825.       DELSIG(4)=C1*DELEPS(4)
  2826.       DELSIG(5)=C1*DELEPS(5)
  2827.       DELSIG(6)=C1*DELEPS(6)
  2828. C
  2829. C        3. WITH THE ASSUMPTION OF ELASTIC BEHAVIOR DURING
  2830. C           THIS INCREMENT, DETERMINE WHERE THE NEW STATE OF
  2831. C           STRESS FALLS IN THE STRESS SPACE
  2832. C
  2833.       DM=(DELSIG(1)+DELSIG(2)+DELSIG(3))/3.
  2834.       DX=DELSIG(1) - DM
  2835.       DY=DELSIG(2) - DM
  2836.       DZ=DELSIG(3) - DM
  2837. C
  2838. C
  2839.       SM=(SIG(1)+SIG(2)+SIG(3))/3.
  2840.       SXX=SIG(1) - SM
  2841.       SYY=SIG(2) - SM
  2842.       SZZ=SIG(3) - SM
  2843.       SXY=SIG(4)
  2844.       SXZ=SIG(5)
  2845.       SYZ=SIG(6)
  2846. C
  2847.       IF (MOD.EQ.2) GO TO 150
  2848. C
  2849. C
  2850.       SXX=SXX - ALFAD(1)
  2851.       SYY=SYY - ALFAD(2)
  2852.       SZZ=SZZ - ALFAD(3)
  2853.       SXY=SXY - ALFAD(4)
  2854.       SXZ=SXZ - ALFAD(5)
  2855.       SYZ=SYZ - ALFAD(6)
  2856. C
  2857.   150 RA=.5 * (DX**2 + DY**2 + DZ**2) + DELSIG(4)**2 + DELSIG(5)**2
  2858.      1   + DELSIG(6)**2
  2859.       RB=SXX*DX + SYY*DY +SZZ*DZ +
  2860.      1   2. * (SXY*DELSIG(4) + SXZ*DELSIG(5) + SYZ*DELSIG(6))
  2861. C
  2862.       RD=FTB
  2863.       IF (IPELD.EQ.2) GO TO 160
  2864.       RD=.5*(SXX**2 + SYY**2 + SZZ**2) + SXY**2 + SXZ**2 + SYZ**2
  2865. C
  2866.   160 FTA=RA + RB + RD
  2867. C
  2868. C     RA = 0  IMPLIES PURE HYDROSTATIC LOADING
  2869. C     ( HENCE, IPELD STAYS CONSTANT )
  2870. C
  2871.       IF (RA .EQ. 0.0) GO TO 175
  2872. C
  2873.       IF (FTA-FTB) 170,170,300
  2874. C
  2875. C
  2876. C     WITH THE ASSUMPTION OF ELASTIC BEHAVIOR, STATE OF STRESS FALLS
  2877. C     WITHIN OR ON THE (CURRENT) YIELD SURFACE - E L A S T I C
  2878. C
  2879.   170 IPELD=1
  2880. C
  2881.   175 DO 176 I=1,6
  2882.   176 STRESS(I)=SIG(I) + DELSIG(I)
  2883.       GO TO 520
  2884. C
  2885. C
  2886. C     WITH THE ASSUMPTION OF ELASTIC BEHAVIOR, STATE OF STRESS FALLS
  2887. C     OUTSIDE THE (CURRENT) YIELD SURFACE - P L A S T I C
  2888. C
  2889.   300 IPELD=2
  2890. C
  2891. C
  2892. C     ...  DETERMINATION OF PART OF STRAIN TAKEN ELASTICALLY (RATIO) ..
  2893. C
  2894.       RC=RD - FTB
  2895.       RATIO= (-RB + DSQRT(RB**2 - 4.*RA*RC)) / (2.*RA)
  2896.       DO 320 I=1,6
  2897.   320 STRESS(I)=SIG(I) + RATIO*DELSIG(I)
  2898. C
  2899.   330 INTER = 20. * ( DSQRT(FTA/FTB) - 1. )  +  1.
  2900.       IF (INTER.GT.25) INTER=25
  2901.       XM=(1. - RATIO) / DBLE(FLOAT(INTER))
  2902. C
  2903.       DO 380 I=1,6
  2904.   380 DEPS(I)=XM * DELEPS(I)
  2905. C
  2906. C
  2907. C     .....  CALCULATION OF ELASTIC-PLASTIC STRESSES  .....(START).....
  2908. C
  2909.       DO 550 IN=1,INTER
  2910. C
  2911.       CALL MIDEP3
  2912. C
  2913.       DO 420 I=1,6
  2914.       J=6*(I-1)
  2915. C
  2916.       STRESS(I)=STRESS(I) + D(J+1)*DEPS(1) + D(J+2)*DEPS(2)
  2917.      1                    + D(J+3)*DEPS(3) + D(J+4)*DEPS(4)
  2918.      2                    + D(J+5)*DEPS(5) + D(J+6)*DEPS(6)
  2919. C
  2920.   420 CONTINUE
  2921. C
  2922. C     UPDATE PLASTIC STRAINS AND ACCUMULATED EFFECTIVE PLASTIC STRAIN
  2923. C
  2924.       DO 425 I=1,6
  2925.   425 EPSP(I)=EPSP(I) + DEPSP(I)
  2926. C
  2927.       DEPSTR=DSQRT(XCON1*(DEPSP(1)*DEPSP(1) + DEPSP(2)*DEPSP(2) +
  2928.      1            DEPSP(3)*DEPSP(3)) + XCON2*(DEPSP(4)*DEPSP(4) +
  2929.      2            DEPSP(5)*DEPSP(5) + DEPSP(6)*DEPSP(6)))
  2930. C
  2931.       EPSTRD=EPSTRD + DEPSTR
  2932. C
  2933.       IF (MOD.EQ.2) GO TO 440
  2934. C
  2935. C     FOR KINEMATIC HARDENING, UPDATE ALFAD(I)
  2936. C
  2937.       ALFAD(1)=ALFAD(1) + CEE*DEPSP(1)
  2938.       ALFAD(2)=ALFAD(2) + CEE*DEPSP(2)
  2939.       ALFAD(3)=ALFAD(3) + CEE*DEPSP(3)
  2940.       ALFAD(4)=ALFAD(4) + 0.5*CEE*DEPSP(4)
  2941.       ALFAD(5)=ALFAD(5) + 0.5*CEE*DEPSP(5)
  2942.       ALFAD(6)=ALFAD(6) + 0.5*CEE*DEPSP(6)
  2943. C
  2944.       GO TO 500
  2945. C
  2946.   440 SM=(STRESS(1)+STRESS(2)+STRESS(3))/3.
  2947.       SX=STRESS(1) - SM
  2948.       SY=STRESS(2) - SM
  2949.       SZ=STRESS(3) - SM
  2950.       FTA=.5 * (SX**2 + SY**2 + SZ**2) +
  2951.      1    STRESS(4)**2 + STRESS(5)**2 + STRESS(6)**2
  2952. C
  2953.       IF (ET.NE.0.0) GO TO 500
  2954. C
  2955. C     PERFECTLY PLASTIC MATERIAL  -  APPLY CORRECTION (IF NECESSARY)
  2956. C
  2957.   480 FTR=DSQRT(FTA/FTB)
  2958. C
  2959. C     CORRECTION
  2960. C
  2961.       ICOR=ICOR + 1
  2962.       COEF=-1. + (1./FTR)
  2963. C
  2964.       STRESS(1)=STRESS(1) + COEF*SX
  2965.       STRESS(2)=STRESS(2) + COEF*SY
  2966.       STRESS(3)=STRESS(3) + COEF*SZ
  2967. C
  2968.       COEF= 1. + COEF
  2969.       STRESS(4)=STRESS(4)*COEF
  2970.       STRESS(5)=STRESS(5)*COEF
  2971.       STRESS(6)=STRESS(6)*COEF
  2972. C
  2973. C     UPDATE HARDENING MODULUS
  2974. C
  2975.   500 IF (NCON.GE.6) GO TO 510
  2976. C
  2977. C     BILINEAR STRESS-STRAIN CURVE
  2978. C
  2979.       IF (MOD.EQ.1) GO TO 550
  2980.       IF (ET.NE.0.0) BET=HP/FTA
  2981.       GO TO 550
  2982. C
  2983. C     PIECEWISE-LINEAR STRESS-STRAIN CURVE
  2984. C
  2985.   510 ETOLD=ET
  2986.       CALL HARDM3 (PROP,EPSTRD,ET)
  2987.       EET=YM*ET/(YM - ET)
  2988.       CEE=XCON1*EET
  2989.       HP=(A3*A3)/(CEE + A3)/2.
  2990. C
  2991.       IF (MOD.EQ.2) GO TO 530
  2992. C
  2993.       BET=HP/FTB
  2994.       GO TO 550
  2995. C
  2996.   530 BET=HP/FTA
  2997.       IF (ETOLD.EQ.0.0) BET=HP/FTB
  2998.       IF (ETOLD.NE.0.0 .AND. ET.EQ.0.0) FTB=FTA
  2999. C
  3000.   550 CONTINUE
  3001. C
  3002. C     .....  CALCULATION OF ELASTIC-PLASTIC STRESSES  .....(E N D).....
  3003. C
  3004.       IF (MOD.EQ.1) GO TO 520
  3005.       IF (ETOLD.NE.0.0) YIELDD=FTA
  3006.       IF (NCON.GE.6 .AND. ETOLD.EQ.0.0) YIELDD=FTB
  3007. C
  3008. C     STRESS ROTATION IS APPLIED IN LARGE DISPLACEMENT/STRAIN
  3009. C     (U.L.J.) FORMULATION
  3010.   520 IF (INDNL.NE.3) GO TO 600
  3011.       OMEGA1=DISD(4) - DISD(6)
  3012.       OMEGA2=DISD(5) - DISD(8)
  3013.       OMEGA3=DISD(7) - DISD(9)
  3014.       STRESS(1)=STRESS(1) + SIG(4)*OMEGA1 + SIG(5)*OMEGA2
  3015.       STRESS(2)=STRESS(2) - SIG(4)*OMEGA1 + SIG(6)*OMEGA3
  3016.       STRESS(3)=STRESS(3) - SIG(5)*OMEGA2 - SIG(6)*OMEGA3
  3017.       STRESS(4)=STRESS(4) + 0.5*(OMEGA1*(SIG(2) - SIG(1)) +
  3018.      1                      OMEGA3*SIG(5) + OMEGA2*SIG(6))
  3019.       STRESS(5)=STRESS(5) + 0.5*(OMEGA2*(SIG(3) - SIG(1)) +
  3020.      1                      OMEGA1*SIG(6) - OMEGA3*SIG(4))
  3021.       STRESS(6)=STRESS(6) + 0.5*(OMEGA3*(SIG(3) - SIG(2)) -
  3022.      1                      OMEGA2*SIG(4) - OMEGA1*SIG(5))
  3023. C
  3024. C     U P D A T I N G
  3025. C
  3026. C
  3027.   600 IF (IUPDT.NE.0) GO TO 615
  3028.       YIELD=YIELDD
  3029.       IPEL=IPELD
  3030.       EPSTR=EPSTRD
  3031.       DO 610 I=1,6
  3032.       ALFA(I)=ALFAD(I)
  3033.       SIG(I)=STRESS(I)
  3034.   610 EPS(I)=STRAIN(I)
  3035. C
  3036.   615 IF (KPRI.EQ.0) GO TO 700
  3037. C
  3038.       IF (ICOUNT.EQ.3) RETURN
  3039. C
  3040. C
  3041. C     .....  CALCULATION OF STRESS - STRAIN LAW  ......................
  3042. C
  3043. C
  3044. C     IN DIVERGENCE REFORMATION (IEQREF=1), ASSUME ELASTIC BEHAVIOR
  3045. C
  3046.       IF (IEQREF.EQ.1) GO TO 624
  3047.       IF (IPELD.EQ.2) GO TO 650
  3048. C
  3049.   624 DO 625 I=1,36
  3050.   625 D(I)=0.
  3051. C
  3052.       D( 1)=A1
  3053.       D( 8)=A1
  3054.       D(15)=A1
  3055. C
  3056.       D( 2)=B1
  3057.       D( 3)=B1
  3058.       D( 7)=B1
  3059.       D( 9)=B1
  3060.       D(13)=B1
  3061.       D(14)=B1
  3062. C
  3063.       D(22)=C1
  3064.       D(29)=C1
  3065.       D(36)=C1
  3066. C
  3067.       RETURN
  3068. C
  3069. C
  3070.   650 CALL MIDEP3
  3071. C
  3072.       RETURN
  3073. C
  3074. C
  3075. C     PRINTING OF STRESSES
  3076. C
  3077.   700 SM=(STRESS(1) + STRESS(2) + STRESS(3))/3.0
  3078.       SX=STRESS(1) - SM
  3079.       SY=STRESS(2) - SM
  3080.       SZ=STRESS(3) - SM
  3081.       SXY=STRESS(4)
  3082.       SXZ=STRESS(5)
  3083.       SYZ=STRESS(6)
  3084. C
  3085.       IF (MOD.EQ.2) GO TO 710
  3086.       SX=SX - ALFAD(1)
  3087.       SY=SY - ALFAD(2)
  3088.       SZ=SZ - ALFAD(3)
  3089.       SXY=SXY - ALFAD(4)
  3090.       SXZ=SXZ - ALFAD(5)
  3091.       SYZ=SYZ - ALFAD(6)
  3092. C
  3093.   710 FTA=.5 * (SX*SX + SY*SY + SZ*SZ) + SXY*SXY + SXZ*SXZ + SYZ*SYZ
  3094.       YIELDD=DSQRT(3.*YIELDD)
  3095.       FT=DSQRT(3.*FTA)
  3096. C
  3097.       IF (INDNL.NE.2) GO TO 800
  3098. C
  3099. C     IN TOTAL LAGRANGIAN FORMULATION CALCULATE CAUCHY STRESSES
  3100. C
  3101.       CALL CAUCH3
  3102. C
  3103.   800 IF (IPRI.NE.0) RETURN
  3104.       IF (IPS.LT.0) GO TO 850
  3105. C
  3106. C     STRESS PRINTOUT ONLY
  3107. C
  3108.       IF (IPT.GT.1) GO TO 820
  3109. C
  3110. C     PRINT HEADING
  3111. C
  3112.       WRITE (6,2000)
  3113. C
  3114. C     PRINT ELEMENT NUMBER
  3115. C
  3116.       WRITE (6,2005) NEL
  3117. C
  3118. C     PRINT INTEGRATION POINT STRESSES
  3119. C
  3120.   820 WRITE (6,2100) IPT,STATE(IPELD),(STRESS(J),J=1,6),INTER,ICOR
  3121.       WRITE (6,2200) FT,YIELDD,EPSTRD
  3122. C
  3123.       RETURN
  3124. C
  3125. C     STRESS AND STRAIN PRINTOUT
  3126. C
  3127.   850 IF (IPT.GT.1) GO TO 870
  3128. C
  3129. C     PRINT HEADING
  3130. C
  3131.       WRITE (6,2000)
  3132. C
  3133. C     PRINT ELEMENT NUMBER
  3134. C
  3135.       WRITE (6,2005) NEL
  3136. C
  3137. C     PRINT INTEGRATION POINT STRESSES AND STRAINS
  3138. C
  3139.   870 WRITE (6,2100) IPT,STATE(IPELD),(STRESS(J),J=1,6),INTER,ICOR
  3140. C
  3141.       IF (INDNL.EQ.3) GO TO 880
  3142. C
  3143.       WRITE (6,2400) (STRAIN(J),J=1,6)
  3144.       WRITE (6,2500) (EPSP(J),J=1,6)
  3145.       WRITE (6,2200) FT,YIELDD,EPSTRD
  3146. C
  3147.   880 CONTINUE
  3148.       WRITE (6,2200) FT,YIELDD,EPSTRD
  3149. C
  3150.       RETURN
  3151. C
  3152.  2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,5X,2HXX,13X,
  3153.      1        2HYY,13X,2HZZ,13X,2HXY,13X,2HXZ,13X,2HYZ,6X,5HINTER,2X,
  3154.      2        4HICOR,/,1X,7HNUM/IPT,2X,5HSTATE,5X,10HCOMPONENTS)
  3155.  2005 FORMAT (/,1X,I3)
  3156.  2100 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,6X,6(E14.6,1X),1X,I3,
  3157.      1        2X,I3)
  3158.  2200 FORMAT (20X,19HEFFECTIVE STRESS = ,E14.6,
  3159.      1        1X,15HYIELD STRESS = ,E14.6,
  3160.      2        1X,29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/)
  3161.  2400 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
  3162.  2500 FORMAT (25X,7HPLASTIC,3X,6(E14.6,1X))
  3163.  2600 FORMAT (20X,22HPRINCIPAL STRETCHES = ,3(E14.6,2X))
  3164.  2700 FORMAT (20X,39HDIRECTION COSINES OF MAXIMUM STRETCH = ,
  3165.      1        3(E14.6,2X))
  3166. C
  3167.       END
  3168. C *CDC* *DECK MIDEP3
  3169. C *UNI* )FOR,IS  N.MIDEP3, R.MIDEP3
  3170.       SUBROUTINE MIDEP3
  3171. C
  3172.       IMPLICIT REAL*8 (A-H,O-Z)
  3173.       COMMON /MTMD3D/ DP(36),STRESS(6),STRAIN(6),IPT,NEL,IPS
  3174.       COMMON /MISES/ A1,B1,C1,A3,A1I,B1I,C1I,BET,CEE,DEPS(6),DEPSP(6),
  3175.      1               TEPS(6),ALFA(6),HP,FTB,XCON1,XCON2,MOD
  3176. C
  3177.       SM=(STRESS(1)+STRESS(2)+STRESS(3))/3.
  3178.       SXX=STRESS(1) - SM
  3179.       SYY=STRESS(2) - SM
  3180.       SZZ=STRESS(3) - SM
  3181.       SXY=STRESS(4)
  3182.       SXZ=STRESS(5)
  3183.       SYZ=STRESS(6)
  3184. C
  3185.       IF (MOD.EQ.2) GO TO 20
  3186. C
  3187.       SXX=SXX - ALFA(1)
  3188.       SYY=SYY - ALFA(2)
  3189.       SZZ=SZZ - ALFA(3)
  3190.       SXY=SXY - ALFA(4)
  3191.       SXZ=SXZ - ALFA(5)
  3192.       SYZ=SYZ - ALFA(6)
  3193. C
  3194.    20 WP=SXX*DEPS(1) + SYY*DEPS(2) + SZZ*DEPS(3) +
  3195.      1   SXY*DEPS(4) + SXZ*DEPS(5) + SYZ*DEPS(6)
  3196.       BETT=BET
  3197. C
  3198.       IF (WP .LT. 0.0) BETT=0.
  3199. C
  3200. C     CALCULATE PLASTIC STRAIN INCREMENTS
  3201. C
  3202.       XLAMDA=(BETT/(2.*C1))*WP
  3203.       DEPSP(1)=XLAMDA*SXX
  3204.       DEPSP(2)=XLAMDA*SYY
  3205.       DEPSP(3)=XLAMDA*SZZ
  3206.       DEPSP(4)=2.0*XLAMDA*SXY
  3207.       DEPSP(5)=2.0*XLAMDA*SXZ
  3208.       DEPSP(6)=2.0*XLAMDA*SYZ
  3209. C
  3210. C
  3211.       BETA=BETT*SXX
  3212.       DP( 1)=A1 - BETA*SXX
  3213.       DP( 2)=B1 - BETA*SYY
  3214.       DP( 3)=B1 - BETA*SZZ
  3215.       DP( 4)=   - BETA*SXY
  3216.       DP( 5)=   - BETA*SXZ
  3217.       DP( 6)=   - BETA*SYZ
  3218. C
  3219.       BETA=BETT*SYY
  3220.       DP( 7)=DP( 2)
  3221.       DP( 8)=A1 - BETA*SYY
  3222.       DP( 9)=B1 - BETA*SZZ
  3223.       DP(10)=   - BETA*SXY
  3224.       DP(11)=   - BETA*SXZ
  3225.       DP(12)=   - BETA*SYZ
  3226. C
  3227.       BETA=BETT*SZZ
  3228.       DP(13)=DP( 3)
  3229.       DP(14)=DP( 9)
  3230.       DP(15)=A1 - BETA*SZZ
  3231.       DP(16)=   - BETA*SXY
  3232.       DP(17)=   - BETA*SXZ
  3233.       DP(18)=   - BETA*SYZ
  3234. C
  3235.       BETA=BETT*SXY
  3236.       DP(19)=DP( 4)
  3237.       DP(20)=DP(10)
  3238.       DP(21)=DP(16)
  3239.       DP(22)=C1 - BETA*SXY
  3240.       DP(23)=   - BETA*SXZ
  3241.       DP(24)=   - BETA*SYZ
  3242. C
  3243.       BETA=BETT*SXZ
  3244.       DP(25)=DP( 5)
  3245.       DP(26)=DP(11)
  3246.       DP(27)=DP(17)
  3247.       DP(28)=DP(23)
  3248.       DP(29)=C1 - BETA*SXZ
  3249.       DP(30)=   - BETA*SYZ
  3250. C
  3251.       BETA=BETT*SYZ
  3252.       DP(31)=DP( 6)
  3253.       DP(32)=DP(12)
  3254.       DP(33)=DP(18)
  3255.       DP(34)=DP(24)
  3256.       DP(35)=DP(30)
  3257.       DP(36)=C1 - BETA*SYZ
  3258. C
  3259. C
  3260. C
  3261.       RETURN
  3262.       END
  3263. C *CDC* *DECK HARDM3
  3264. C *UNI* )FOR,IS N.HARDM3, R.HARDM3
  3265. C
  3266.       SUBROUTINE HARDM3 (PROP,EPSTR,ET)
  3267. C
  3268. C
  3269. C
  3270. C     THIS SUBROUTINE CALCULATES THE SLOPE OF THE UNIAXIAL
  3271. C     STRESS-STRAIN CURVE CORRESPONDING TO A GIVEN VALUE
  3272. C     OF ACCUMULATED EFFECTIVE PLASTIC STRAIN
  3273. C
  3274. C
  3275. C
  3276. C        NPR  = NUMBER OF PAIRS OF STRESS-STRAIN VALUES DEFINING THE
  3277. C               PLASTIC PORTION OF THE STRESS-STRAIN CURVE
  3278. C        NSEG = NUMBER OF SEGMENTS IN THE PLASTIC PORTION OF THE CURVE
  3279. C
  3280. C
  3281. C
  3282.       IMPLICIT REAL*8 (A-H,O-Z)
  3283. C
  3284.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
  3285.      1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  3286.       DIMENSION PROP(1)
  3287.       EQUIVALENCE (NPAR(17),NCON)
  3288. C
  3289. C
  3290.       YM=PROP(1)
  3291.       NPR=(NCON - 2)/2
  3292.       NSEG=NPR - 1
  3293. C
  3294.       KK=6
  3295.       DO 10 J=1,NSEG
  3296.       TEPSTR=PROP(KK) - (PROP(KK - 1)/YM)
  3297.       IF (EPSTR.LT.TEPSTR) GO TO 20
  3298.    10 KK=KK + 2
  3299. C
  3300.       WRITE (6,2000)
  3301.       STOP
  3302. C
  3303. C     CALCULATE THE HARDENING MODULUS
  3304. C
  3305.    20 ET=(PROP(KK - 1) - PROP(KK - 3))/(PROP(KK) - PROP(KK - 2))
  3306. C
  3307.       RETURN
  3308. C
  3309.  2000 FORMAT (126H   ERROR   ACCUMULATED EFFECTIVE PLASTIC STRAIN IS OUT
  3310.      1SIDE THE RANGE OF THE UNIAXIAL STRESS-STRAIN CURVE   (SUBROUTINE H
  3311.      2ARDM3))
  3312. C
  3313.       END
  3314. C *CDC* *DECK OVL46
  3315. C *CDC*       OVERLAY(ADINA,4,6)
  3316. C *CDC* *DECK EL3D10
  3317. C *UNI* )FOR,IS  N.EL3D10, R.EL3D10
  3318. C *CDC*       PROGRAM  EL3D10
  3319. C
  3320.       SUBROUTINE EL3D10
  3321. C
  3322. C
  3323. C
  3324. C     THERMOELASTIC/PLASTIC/CREEP MATERIAL MODEL
  3325. C        MODEL = 10  (ISOTROPIC HARDENING, VON MISES YIELD CRITERION)
  3326. C        MODEL = 11  (KINEMATIC HARDENING, VON MISES YIELD CRITERION)
  3327. C
  3328. C
  3329. C
  3330.       IMPLICIT REAL*8 (A-H,O-Z)
  3331. C
  3332.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  3333.      1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  3334.       COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
  3335.      1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
  3336.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  3337.       COMMON /DPR/ ITWO
  3338.       COMMON A(1)
  3339.       COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
  3340. C
  3341.       REAL A
  3342. C
  3343.       DIMENSION IA(1)
  3344. C
  3345.       EQUIVALENCE (NPAR(10),NINT),(A(1),IA(1)),(NPAR(17),NCON),
  3346.      1            (NPAR(7),MXNODS),(NPAR(11),NINTZ)
  3347. C
  3348. C
  3349. C
  3350. C     FOR ADDRESSES N101,N102,..........SEE SUBROUTINE THREDM
  3351. C
  3352. C     QUANTITIES STORED FOR EACH INTEGRATION POINT
  3353. C
  3354. C        STRESS COMPONENTS
  3355. C        TOTAL STRAIN COMPONENTS
  3356. C        PLASTIC STRAIN COMPONENTS
  3357. C        CREEP STRAIN COMPONENTS
  3358. C        YIELD STRESS
  3359. C        ACCUMULATED INCREMENTS OF EFFECTIVE PLASTIC STRAIN
  3360. C        YIELD SURFACE TRANSLATION COMPONENTS
  3361. C        ORIGINS FOR O.R.N.L. CYCLIC CREEP
  3362. C        TEMPERATURE
  3363. C        IPEL AND NORG
  3364. C        IPEL = 1 THERMO-ELASTIC AND CREEP BEHAVIOR
  3365. C             = 2 THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR
  3366. C        NORG = 1 POSITIVE ORIGIN
  3367. C             = 2 NEGATIVE ORIGIN
  3368. C
  3369. C     QUANTITIES STORED FOR EACH ELEMENT
  3370. C
  3371. C        GLOBAL NODAL POINT NUMBERS
  3372. C
  3373. C
  3374. C
  3375.       IDW=47*ITWO
  3376.       NPT=NINT*NINT*NINTZ
  3377. C
  3378. C        1. DETERMINE MATERIAL PROPERTY SET NUMBER
  3379. C
  3380.       MATP=IA(N107 + NEL - 1)
  3381. C
  3382. C        2. DETERMINE MATERIAL PROPERTY SET LOCATIONS
  3383. C
  3384.       NM=N111 + (MATP - 1)*NCON*ITWO
  3385. C
  3386. C        3. INITIALIZE WORKING ARRAY
  3387. C
  3388.       IF(IND.NE.0) GO TO 100
  3389.       NN=N112+(NEL-1)*(IDW*NPT+MXNODS)
  3390.       CALL IEPC3(A(NN),A(NN + IDW*NPT),A(NN),IDW,A(N6A + ITWO),A(NM))
  3391.       GO TO 200
  3392. C
  3393. C        4. DETERMINE LOCATIONS OF VARIABLES IN WORKING ARRAY
  3394. C
  3395.   100 NN=N112+(NEL-1)*(IDW*NPT+MXNODS)+(IPT-1)*IDW
  3396.       NN1=NN
  3397.       NN2=NN+6*ITWO
  3398.       NN3=NN+12*ITWO
  3399.       NN4=NN+18*ITWO
  3400.       NN5=NN+24*ITWO
  3401.       NN6=NN+25*ITWO
  3402.       NN7=NN + 26*ITWO
  3403.       NN8=NN + 32*ITWO
  3404.       NN9=NN + 44*ITWO
  3405.       NN10=NN + 45*ITWO
  3406.       NN11=NN + 46*ITWO
  3407. C
  3408. C        5. DETERMINE ELEMENT GLOBAL NODAL POINT NUMBERS LOCATION
  3409. C
  3410.       KK=N112+(NEL-1)*(IDW*NPT+MXNODS)+IDW*NPT
  3411. C
  3412. C        6. DETERMINE MIDSIDE NODE ARRAY LOCATION
  3413. C
  3414.       ND9DIM=MXNODS-8
  3415.       LL=N108+(NEL-1)*ND9DIM
  3416. C
  3417. C        7. CALCULATE STRESSES AND CONSTITUTIVE LAW
  3418. C
  3419.       CALL EPC3(A(NM),A(NN1),A(NN2),A(NN3),A(NN4),A(NN5),A(NN6),A(NN7),
  3420.      1          A(NN8),A(NN9),A(NN10),A(NN11),A(KK),A(LL),A(N6A + ITWO),
  3421.      2          A(N6B + ITWO))
  3422. C
  3423.   200 CONTINUE
  3424. C
  3425.       RETURN
  3426.       END
  3427. C *CDC* *DECK IEPC3
  3428. C *UNI* )FOR,IS  N.IEPC3, R.IEPC3
  3429. C
  3430.       SUBROUTINE IEPC3(WA,IWA,IIWA,IIDW,TEMPV1,PROP)
  3431. C
  3432. C
  3433. C
  3434. C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR
  3435. C     THE THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
  3436. C     (MODELS = 10 AND 11)
  3437. C
  3438. C
  3439. C
  3440.       IMPLICIT REAL*8 (A-H,O-Z)
  3441. C
  3442.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  3443.      1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  3444.       COMMON /EM3D/ NOD(21),NODM(21),NOD9M(13)
  3445.       COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
  3446.       COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
  3447.       COMMON /DPR/ ITWO
  3448.       COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
  3449.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  3450.      1                TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  3451.      2                SUBDD,RNGL,RNGU,DTT,TOL7,
  3452.      3                KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  3453. C
  3454.       DIMENSION WA(47,1),IWA(1),IIWA(IIDW,1),TEMPV1(1),H(21),
  3455.      1          XDM1(3,21),XDM2(3,3),XDM3(3,1),PROP(16,1),PROP1(5)
  3456. C
  3457.       EQUIVALENCE (NPAR(10),NINT),(NPAR(11),NINTZ)
  3458. C
  3459.       NPT=NINT*NINT*NINTZ
  3460.       IINTP=1
  3461.       NPTS=IDINT(PROP(9,7))
  3462.       TOLMT=1.0D-2
  3463. C
  3464.       TOLL=TOLMT*DABS(PROP(1,1))
  3465.       IF(TOLL.EQ.0.0) TOLL=TOLMT
  3466.       TOLU=TOLMT*DABS(PROP(NPTS,1))
  3467.       IF(TOLU.EQ.0.0) TOLU=TOLMT
  3468. C
  3469.       RNGL=PROP(1,1) - TOLL
  3470.       RNGU=PROP(NPTS,1) + TOLU
  3471. C
  3472. C        1. SET ALL FLOATING-POINT VARIABLES IN THE WORKING ARRAY
  3473. C           TO ZERO
  3474. C
  3475.    15 DO 20 J=1,NPT
  3476.       DO 20 I=1,45
  3477.    20 WA(I,J)=0.0
  3478. C
  3479. C        2. STORE GLOBAL NODAL POINT NUMBERS
  3480. C
  3481.       II=0
  3482.       DO 25 K=1,21
  3483.       IF(NODM(K).EQ.0) GO TO 25
  3484.       II=II+1
  3485.       IWA(II)=NODM(K)
  3486.    25 CONTINUE
  3487. C
  3488. C        3. INTERPOLATE INITIAL TEMPERATURE DISTRIBUTION
  3489. C           STORE INITIAL INTEGRATION POINT TEMPERATURES
  3490. C
  3491.       IPT=0
  3492.       DO 30 LX=1,NINT
  3493.       E1=XG(LX,NINT)
  3494.       DO 30 LY=1,NINT
  3495.       E2=XG(LY,NINT)
  3496.       DO 30 LZ=1,NINTZ
  3497.       E3=XG(LZ,NINTZ)
  3498.       IPT=IPT+1
  3499.       CALL FUNCT(E1,E2,E3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
  3500.       TEMP1=0.0
  3501.       DO 35 K=1,IEL
  3502.       KK=IWA(K)
  3503.    35 TEMP1=TEMP1+H(K)*TEMPV1(KK)
  3504.       WA(45,IPT)=TEMP1
  3505. C
  3506. C        4. INITIALIZE AND STORE YIELD STRESS
  3507. C
  3508.       CALL MTITP3(PROP,TEMP1,PROP1)
  3509.       YS1=PROP1(3)
  3510.    30 WA(25,IPT)=YS1
  3511. C
  3512. C        5. INITIALIZE INTEGER VARIABLES IN THE WORKING ARRAY
  3513. C           TO ONE
  3514. C
  3515.       KJ=45*ITWO + 1
  3516.       KJJ=46*ITWO + 1
  3517.       DO 40 I=1,NPT
  3518.       IIWA(KJ,I)=1
  3519.    40 IIWA(KJJ,I)=1
  3520. C
  3521.       RETURN
  3522. C
  3523.       END
  3524. C *CDC* *DECK EPC3
  3525. C *UNI* )FOR,IS  N.EPC3, R.EPC3
  3526. C
  3527.       SUBROUTINE EPC3(PROP,SIG,EPS,EPSP,EPSC,YLD,EPSTR,ALFA,ORIG,TMPOLD,
  3528.      1                IPEL,NORG,NDS,NOD9M,TEMPV1,TEMPV2)
  3529. C
  3530. C
  3531. C
  3532. C     THIS SUBROUTINE CALCULATES THE STRESSES, PLASTIC STRAINS,
  3533. C     CREEP STRAINS, AND THE CONSTITUTIVE LAW FOR THE
  3534. C     THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
  3535. C     (MODELS = 10 AND 11)
  3536. C
  3537. C
  3538. C
  3539. C     NALG = 1  ALGORITHM USES ISUBM SUBDIVISIONS OF EQUAL SIZE
  3540. C
  3541. C          = 2  ALGORITHM USES VARIABLE SIZE SUBDIVISIONS UP TO A
  3542. C               MAXIMUM OF ISUBM
  3543. C
  3544. C
  3545. C
  3546. C     THE FOLLOWING VARIABLES ARE USED
  3547. C
  3548. C        SIG = STRESSES AT TIME OF LAST UPDATE
  3549. C        EPS = TOTAL STRAINS AT TIME OF LAST UPDATE
  3550. C        EPSP = PLASTIC STRAINS AT TIME OF LAST UPDATE
  3551. C        EPSC = CREEP STRAINS AT TIME OF LAST UPDATE
  3552. C        YLD = YIELD STRESS AT TIME OF LAST UPDATE
  3553. C        EPSTR = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT TIME OF LAST
  3554. C                UPDATE
  3555. C        ORIG = ORIGINS FOR O.R.N.L. CYCLIC CREEP AT TIME OF LAST UPDATE
  3556. C        ALFA = YIELD SURFACE TRANSLATION COMPONENTS AT TIME OF LAST
  3557. C               UPDATE
  3558. C        IPEL = ELASTIC-PLASTIC INDICATOR AT TIME OF LAST UPDATE
  3559. C        NORG = CYCLIC CREEP ORIGIN INDICATOR AT TIME OF LAST UPDATE
  3560. C        TREF = REFERENCE TEMPERATURE
  3561. C        KCRP = CREEP LAW NUMBER
  3562. C        CRPCON = CREEP LAW COEFFICIENTS
  3563. C        XINTP = INTEGRATION PARAMETER
  3564. C        ISUBM = MAXIMUM NUMBER OF SUBDIVISIONS
  3565. C        NITE = MAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION
  3566. C        NALG = ALGORITHM INDICATOR
  3567. C        TOLIL,TOL1 = CONVERGENCE TOLERANCES
  3568. C        TOL2,TOL5 = ZERO TOLERANCES
  3569. C        TOL3,TOL4 = ROUNDOFF TOLERANCES
  3570. C        TOL6,TOL7 = YIELD SURFACE TOLERANCES
  3571. C        TOLPC = INELASTIC STRAIN TOLERANCE
  3572. C        TOLMT = MATERIAL PROPERTY EXTREME TEMPERATURE TOLERANCE
  3573. C        DTT = CURRENT TIME STEP
  3574. C        DTOD = OLD TIME STEP WHEN USING RESTART
  3575. C        DELT = TIME STEP SUBDIVISION
  3576. C        STRAIN = TOTAL STRAINS
  3577. C        STRESS = STRESSES
  3578. C        DELEPS = INCREMENT IN TOTAL STRAINS
  3579. C        EPS1 = TOTAL STRAINS AT START OF SUBDIVISION
  3580. C        EPS2 = TOTAL STRAINS AT END OF SUBDIVISION
  3581. C        DEPS = CHANGE IN TOTAL STRAINS FOR THE SUBDIVISION
  3582. C        STRSS1,STRSS2 = STRESSES AT START AND END OF SUBDIVISION
  3583. C        STRSSM = WEIGHTED STRESSES
  3584. C        DELSIG = CHANGE IN STRESSES FOR THE SUBDIVISION
  3585. C        EPST1,EPST2 = THERMAL STRAINS AT START AND END OF SUBDIVISION
  3586. C        THSTR1 = THERMAL STRAIN RATE AT START OF SUBDIVISION
  3587. C        DPST = CHANGE IN THERMAL STRAINS FOR THE SUBDIVISION
  3588. C        EPSC1,EPSC2 = CREEP STRAINS AT START AND END OF SUBDIVISION
  3589. C        EPSCM = WEIGHTED CREEP STRAINS
  3590. C        DPSC = CHANGE IN CREEP STRAINS FOR THE SUBDIVISION
  3591. C        EPSP1,EPSP2 = PLASTIC STRAINS AT START AND END OF SUBDIVISION
  3592. C        DPSP = CHANGE IN PLASTIC STRAINS FOR THE SUBDIVISION
  3593. C        EPSTR1,EPSTR2 = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT START
  3594. C                        AND END OF SUBDIVISION
  3595. C        EPSTRM = WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
  3596. C        TEMP1,TEMP2 = TEMPERATURES AT START AND END OF CURRENT
  3597. C                      SOLUTION STEP
  3598. C        TMP1,TMP2 = TEMPERATURES AT START AND END OF SUBDIVISION
  3599. C        TMPM = WEIGHTED TEMPERATURE
  3600. C        ALFA1,ALFA2 = YIELD SURFACE TRANSLATION COMPONENTS AT START
  3601. C                      AND END OF SUBDIVISION
  3602. C        ALFAM = WEIGHTED YIELD SURFACE TRANSLATION COMPONENTS
  3603. C        C = CONSTITUTIVE MATRIX  (ELASTIC OR ELASTIC-PLASTIC)
  3604. C        PROP1,PROP2 = MATERIAL PROPERTIES AT START AND END OF
  3605. C                      SUBDIVISION
  3606. C        PROPM = WEIGHTED MATERIAL PROPERTIES
  3607. C        YLD1,YLD2 = YIELD STRESS AT START AND END OF SUBDIVISION
  3608. C        YLDM = WEIGHTED YIELD STRESS
  3609. C        XLAMDA = LOADING/UNLOADING/NEUTRAL LOADING INDICATOR
  3610. C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
  3611. C
  3612. C
  3613. C
  3614.       IMPLICIT REAL*8 (A-H,O-Z)
  3615. C
  3616.       COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9
  3617.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  3618.      1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  3619.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  3620.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  3621.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  3622.       COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
  3623.       COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),Z1,Z2,Z3
  3624.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  3625.      1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  3626.      2               SUBDD,RNGL,RNGU,DTT,TOL7,
  3627.      3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  3628.       COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
  3629. C
  3630.       DIMENSION PROP(16,1),SIG(1),EPS(1),EPSC(1),ALFA(1),ORIG(6,1),
  3631.      1          ORIGD(6,2),NDS(1),NOD9M(1),TEMPV1(1),TEMPV2(1),
  3632.      2          STATE(2),H(21),XDM1(3,21),XDM2(3,3),XDM3(3,1),
  3633.      3          DELSIG(6),DELEPS(6),DEPS(6),EPSP1(6),EPSP2(6),
  3634.      4          STRSS1(6),STRSS2(6),STRSSM(6),EPSC1(6),EPSC2(6),
  3635.      5          EPSCM(6),DPSC(6),ALFA1(6),ALFA2(6),ALFAM(6),
  3636.      6          EPS1(6),EPS2(6),PROP1(5),DEPST(6),PROP2(5),PROPM(5)
  3637.       DIMENSION STRSSD(6),DPSP(6),EPST2(6),EPSP(1),CEP(6,6),EPST1(6),
  3638.      1          DSTSS(6)
  3639. C
  3640.       EQUIVALENCE (NPAR(15),MODEL),(NPAR(3),INDNL),
  3641.      1            (STRESS(1),STRSS2(1))
  3642. C
  3643.       DATA STATE /2H E,2H*P/
  3644. C
  3645. C
  3646. C
  3647. C        1. INITIALIZE SOLUTION PARAMETERS
  3648. C
  3649.       INDEX=1
  3650.       ISUB=1
  3651.       ISUBM=IDINT(PROP(13,7))
  3652. C
  3653.       IF(IPT.GT.1) GO TO 5
  3654. C
  3655. C     SET TIME STEP SIZE **
  3656. C
  3657.       DTT=DT
  3658.       IF(MODEX.EQ.2.AND.KSTEP.EQ.1.AND.ICOUNT.NE.3.AND.
  3659.      1   KPRI.NE.0) DTT=DTOD
  3660. C
  3661.       SUBDD=5.0
  3662.       DTMN=DTT/PROP(13,7)
  3663.       IINTP=1
  3664. C
  3665.       DO 2 J=1,8
  3666.     2 CRPCON(J)=PROP(J,7)
  3667. C
  3668.       NPTS=IDINT(PROP(9,7))
  3669.       TREF=PROP(10,7)
  3670.       KCRP=IDINT(PROP(11,7))
  3671.       XINTP=PROP(12,7)
  3672.       NITE=IDINT(PROP(14,7))
  3673.       NALG=IDINT(PROP(15,7))
  3674.       TOLIL=PROP(16,7)
  3675.       TOLPC=PROP(1,8)
  3676. C
  3677.       XCON1=2.0/3.0
  3678.       XCON2=1.0/3.0
  3679. C
  3680.       ITCHK=1
  3681.       IF(NITE.LT.6) ITCHK=0
  3682. C
  3683. C     SET INTEGRATION PARAMETERS **
  3684. C
  3685.       XPARM1=1.0 - XINTP
  3686.       XPARM2=XINTP
  3687. C
  3688. C     SET TOLERANCES **
  3689. C
  3690.       TOL1=TOLIL*TOLIL
  3691.       TOL4=5.0D-6
  3692.       TOL5=1.0D-20
  3693.       TOL2=TOL5*TOL5
  3694.       TOL3=2.0*TOL4
  3695.       TOL6=0.1
  3696.       TOL7=2.0
  3697.       TOLMT=1.0D-2
  3698.       TCHK=DTT*(1.0 - TOL4)
  3699. C
  3700.       TOLL=TOLMT*DABS(PROP(1,1))
  3701.       IF(TOLL.EQ.0.0) TOLL=TOLMT
  3702.       TOLU=TOLMT*DABS(PROP(NPTS,1))
  3703.       IF(TOLU.EQ.0.0) TOLU=TOLMT
  3704. C
  3705.       RNGL=PROP(1,1) - TOLL
  3706.       RNGU=PROP(NPTS,1) + TOLU
  3707. C
  3708. C        2. INITIALIZE SOLUTION VARIABLES
  3709. C
  3710.     5 DO 10 I=1,6
  3711.       EPS1(I)=EPS(I)
  3712.       EPSP1(I)=EPSP(I)
  3713.       EPSP2(I)=EPSP(I)
  3714.       ALFA1(I)=ALFA(I)
  3715.       ALFA2(I)=ALFA(I)
  3716.       EPSC1(I)=EPSC(I)
  3717.       EPSC2(I)=EPSC(I)
  3718.       DPSC(I)=0.0
  3719.       EPST1(I)=0.0
  3720.       EPST2(I)=0.0
  3721.       DEPST(I)=0.0
  3722.       STRSS2(I)=SIG(I)
  3723.    10 STRSS1(I)=SIG(I)
  3724. C
  3725.       YLD1=YLD
  3726.       EPSTR1=EPSTR
  3727.       EPSTR2=EPSTR
  3728.       ECSTR1=0.0
  3729.       CRSRM=0.0
  3730.       TMP1=TMPOLD
  3731.       IPELD=IPEL
  3732.       NORGD=NORG
  3733.       TAU=0.0
  3734.       ESTM=0.0
  3735. C
  3736.       DO 20 I=1,6
  3737.       DO 20 J=1,2
  3738.    20 ORIGD(I,J)=ORIG(I,J)
  3739. C
  3740. C        3. CALCULATE TOTAL STRAIN INCREMENT
  3741. C
  3742.       DO 25 J=1,6
  3743.    25 DELEPS(J)=STRAIN(J) - EPS(J)
  3744. C
  3745. C        4. CALCULATE TEMPERATURE INCREMENT
  3746. C
  3747. C     CALCULATE INTEGRATION POINT TEMPERATURES **
  3748. C
  3749.       CALL FUNCT(Z1,Z2,Z3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
  3750.       TEMP1=0.0
  3751.       TEMP2=0.0
  3752. C
  3753.       DO 30 K=1,IEL
  3754.       KK=NDS(K)
  3755.       TEMP2=TEMP2 + H(K)*TEMPV2(KK)
  3756.    30 TEMP1=TEMP1 + H(K)*TEMPV1(KK)
  3757. C
  3758.       CTEMP=TEMP2
  3759. C
  3760. C     CHECK FOR START OF A SOLUTION STEP *
  3761. C
  3762.       IF(ICOUNT.NE.3.AND.KPRI.NE.0) CTEMP=TEMP1
  3763. C
  3764.       DELTMP=CTEMP - TMPOLD
  3765. C
  3766. C        5. CALCULATE MATERIAL PROPERTIES AT TIME OF LAST UPDATE
  3767. C
  3768.       CALL EMAT3(TMPOLD,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
  3769. C
  3770.       YM1=PROP1(1)
  3771.       ET1=PROP1(4)
  3772.       YS1=PROP1(3)
  3773. C
  3774.       EET1=YM1*ET1/(YM1 - ET1)
  3775. C
  3776. C        6. CALCULATE SIZE OF FIRST SUBDIVISION
  3777. C           (STRESS LOOP NO. 1)
  3778. C
  3779.    40 DELT=DTMN
  3780.       IF(KCRP.EQ.0.AND.NALG.EQ.2) DELT=DTT
  3781. C
  3782. C        7. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
  3783. C
  3784.    60 XFAC=(TAU + DELT)/DTT
  3785.       DO 65 J=1,6
  3786.       EPS2(J)=EPS(J) + XFAC*DELEPS(J)
  3787.    65 DEPS(J)=EPS2(J) - EPS1(J)
  3788. C
  3789. C        8. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
  3790. C
  3791.       TMP2=TMPOLD + XFAC*DELTMP
  3792.       TMPM=XPARM1*TMP1 + XPARM2*TMP2
  3793. C
  3794.       CALL EMAT3(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
  3795. C
  3796. C        9. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
  3797. C
  3798.       ALPHA2=PROP2(5)
  3799. C
  3800.       EPST2(1)=ALPHA2*(TMP2 - TREF)
  3801.       EPST2(2)=EPST2(1)
  3802.       EPST2(3)=EPST2(1)
  3803. C
  3804. C        10. CALCULATE WEIGHTED STRESS
  3805. C
  3806.       IF(KCRP.EQ.0) GO TO 95
  3807. C
  3808.    70 DO 75 J=1,6
  3809.    75 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
  3810. C
  3811. C        11. PRELIMINARY CREEP CALCULATIONS
  3812. C
  3813.       DO 80 J=1,6
  3814.    80 DPSC(J)=0.0
  3815.       CRSRM=0.0
  3816. C
  3817.       CALL EFST3(ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,STRSSM)
  3818.       IF(ESTM.LE.TOL5.AND.INDEX.GT.1) GO TO 95
  3819. C
  3820.       DO 90 J=1,6
  3821.    90 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
  3822. C
  3823.       CALL CREEP3(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
  3824.      1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,
  3825.      2            FF,RR,GG,INDEX,ECSTRM)
  3826. C
  3827.       IF(INDEX.EQ.1) ECSTR1=ECSTRM
  3828. C
  3829. C        12. CALCULATE THE STRESSES AND CREEP STRAINS AT END OF
  3830. C             SUBDIVISION, ASSUMING THERMO-ELASTIC AND CREEP BEHAVIOR
  3831. C
  3832.    95 CALL SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
  3833.      1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,DELT,
  3834.      2            B2,C2,D2)
  3835. C
  3836. C        13. CHECK FOR CONVERGENCE OF ITERATION
  3837. C
  3838. C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ. 0),
  3839. C     WHEN KCRP .EQ. 0, OR WHEN XPARM2 .EQ. 0 **
  3840. C
  3841.   100 IF(KCRP.EQ.0) GO TO 215
  3842.       IF(XPARM2.EQ.0.0) GO TO 205
  3843.       IF(ITCHK.EQ.1) GO TO 120
  3844. C
  3845.       INDEX=INDEX + 1
  3846.       IF(INDEX.LE.NITE) GO TO 70
  3847.       GO TO 205
  3848. C
  3849. C     CALCULATE THE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
  3850. C     STRESS VECTOR **
  3851. C
  3852.   120 IF(INDEX - 4) 122,135,125
  3853. C
  3854.   122 INDEX=INDEX + 1
  3855.       GO TO 70
  3856. C
  3857.   125 DNORM2=0.0
  3858.       DO 130 J=1,6
  3859.   130 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
  3860. C
  3861. C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
  3862. C
  3863.   135 SNORM=0.0
  3864.       DO 140 J=1,6
  3865.   140 SNORM=SNORM + STRSS2(J)*STRSS2(J)
  3866. C
  3867. C     VALUE OF INDEX .LE. 5 **
  3868. C
  3869.       IF(INDEX.GT.5) GO TO 155
  3870.       SNORM2=SNORM
  3871.       IF(INDEX.EQ.4) SNORM1=SNORM2
  3872.       IF(INDEX.EQ.5) DNORM1=DNORM2
  3873.       INDEX=INDEX + 1
  3874. C
  3875.       DO 150 J=1,6
  3876.   150 STRSSD(J)=STRSS2(J)
  3877.       GO TO 70
  3878. C
  3879. C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
  3880. C
  3881. C
  3882. C     INITIAL CHECK FOR CONVERGENCE *
  3883. C
  3884.   155 IF(DNORM2.LE.DNORM1) GO TO 185
  3885. C
  3886. C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
  3887. C     TOLERANCE BAND
  3888. C
  3889.       XTOL=TOL3*SNORM1
  3890.       IF(SNORM1.LE.TOL2) XTOL=TOL2
  3891.       IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 205
  3892. C
  3893. C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
  3894. C     (NALG .EQ. 2) *
  3895. C
  3896.       DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
  3897.       IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 170
  3898. C
  3899.       WRITE(6,3004)
  3900.       WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
  3901.       STOP
  3902. C
  3903. C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
  3904. C
  3905.   170 INDEX=1
  3906. C
  3907.       DO 180 I=1,6
  3908.       STRSS2(I)=STRSS1(I)
  3909.   180 EPSC2(I)=EPSC1(I)
  3910. C
  3911.       GO TO 60
  3912. C
  3913. C     FINAL CHECK FOR CONVERGENCE *
  3914. C
  3915.   185 XTOL=TOL1*SNORM1
  3916.       IF(SNORM1.LE.TOL2) XTOL=TOL2
  3917.       IF(DNORM1.LE.XTOL) GO TO 205
  3918. C
  3919. C     NO CONVERGENCE
  3920. C
  3921.   190 INDEX=INDEX + 1
  3922.       IF(INDEX.LE.NITE) GO TO 195
  3923. C
  3924.       WRITE(6,3001)
  3925.       WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
  3926.       STOP
  3927. C
  3928.   195 DNORM1=DNORM2
  3929.       SNORM1=SNORM2
  3930.       SNORM2=SNORM
  3931. C
  3932.       DO 200 J=1,6
  3933.   200 STRSSD(J)=STRSS2(J)
  3934.       GO TO 70
  3935. C
  3936. C        14. CHECK SIZE OF CREEP STRAIN INCREMENT
  3937. C
  3938. C     CHECK IS BYPASSED WHEN THE MODIFIED EFFECTIVE CREEP STRAIN AT
  3939. C     THE START OF THE SUBDIVISION AND/OR THE EFFECTIVE CREEP STRAIN
  3940. C     RATE FOR THE SUBDIVISION .EQ. 0, OR WHEN KCRP .EQ. 0 **
  3941. C
  3942.   205 DECSTR=CRSRM*DELT
  3943.       IF(DECSTR.LE.TOL5 .OR. ECSTR1.LE.TOL5) GO TO 215
  3944. C
  3945.       CHECK=DECSTR/(ECSTR1*TOLPC)
  3946.       IF(CHECK.LE.1.1) GO TO 215
  3947. C
  3948. C     CREEP STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
  3949. C     SUBDIVISION SIZE **
  3950. C
  3951.       DELT=DELT/CHECK
  3952.       IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 208
  3953. C
  3954.       WRITE(6,3006)
  3955.       WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
  3956.       STOP
  3957. C
  3958. C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
  3959. C
  3960.   208 INDEX=1
  3961. C
  3962.       DO 210 I=1,6
  3963.       EPSC2(I)=EPSC1(I)
  3964.   210 STRSS2(I)=STRSS1(I)
  3965. C
  3966.       GO TO 60
  3967. C
  3968. C        15. CHECK FOR YIELDING
  3969. C
  3970. C     DETERMINE LOCATION OF THE STRESS-TEMPERATURE STATE AT END OF
  3971. C     SUBDIVISION WITH RESPECT TO THE YIELD SURFACE (ASSUMING NO
  3972. C     PLASTICITY) **
  3973. C
  3974.   215 CALL EFST3(EST2,SX2,SY2,SZ2,SXY2,SXZ2,SYZ2,STRSS2)
  3975. C
  3976.       DO 218 I=1,6
  3977.   218 DELSIG(I)=STRSS2(I) - STRSS1(I)
  3978. C
  3979.       CALL EFST3(EST,DX,DY,DZ,DXY,DXZ,DYZ,DELSIG)
  3980. C
  3981. C     KINEMATIC HARDENING *
  3982. C
  3983.       IF(MODEL.EQ.10) GO TO 220
  3984. C
  3985.       SX2=SX2 - ALFA1(1)
  3986.       SY2=SY2 - ALFA1(2)
  3987.       SZ2=SZ2 - ALFA1(3)
  3988.       SXY2=SXY2 - ALFA1(4)
  3989.       SXZ2=SXZ2 - ALFA1(5)
  3990.       SYZ2=SYZ2 - ALFA1(6)
  3991. C
  3992. C     CALCULATE YIELD STRESS AT END OF SUBDIVISION *
  3993. C
  3994.   220 YM2=PROP2(1)
  3995.       ET2=PROP2(4)
  3996.       YS2=PROP2(3)
  3997. C
  3998.       EET2=YM2*ET2/(YM2 - ET2)
  3999. C
  4000.       DYLD=YS2 - YS1
  4001.       IF(MODEL.EQ.10) DYLD=DYLD + (EET2 - EET1)*EPSTR1
  4002.       YLD2=YLD1 + DYLD
  4003. C
  4004.   225 RA=DX*DX + DY*DY + DZ*DZ + 2.0*(DXY*DXY + DXZ*DXZ + DYZ*DYZ)
  4005.       FTA=SX2*SX2 + SY2*SY2 + SZ2*SZ2 + 2.0*(SXY2*SXY2 + SXZ2*SXZ2 +
  4006.      1    SYZ2*SYZ2)
  4007. C
  4008. C     CHECK FOR NO CHANGE IN DEVIATORIC STRESS-TEMPERATURE STATE *
  4009. C
  4010.       IF(RA.EQ.0.0.AND.TMP1.EQ.TMP2) GO TO 228
  4011. C
  4012.       FTB=XCON1*YLD2*YLD2
  4013.       IF(FTA.GT.FTB) GO TO 250
  4014. C
  4015. C        16. STRESS STATE IS WITHIN THE YIELD SURFACE---
  4016. C            THERMO-ELASTIC/CREEP BEHAVIOR
  4017. C
  4018.       IPELD=1
  4019.   228 TAU=TAU + DELT
  4020. C
  4021. C     CALCULATE SIZE OF NEXT SUBDIVISION **
  4022. C
  4023.       IF(NALG.EQ.2) GO TO 230
  4024. C
  4025. C     NALG .EQ. 1 *
  4026. C
  4027.       IF(ISUB.EQ.ISUBM) GO TO 245
  4028.       GO TO 235
  4029. C
  4030. C    NALG .EQ. 2 *
  4031. C
  4032.   230 IF(TAU.GE.TCHK .OR. KCRP.EQ.0) GO TO 245
  4033.       IF(DECSTR.LE.TOL5) GO TO 232
  4034. C
  4035.       DELT=DELT*TOLPC*(1.0 + (ECSTR1/DECSTR))
  4036.       IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
  4037.       GO TO 233
  4038. C
  4039.   232 DELT=DTT - TAU
  4040. C
  4041. C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
  4042. C     LARGE ENOUGH
  4043. C
  4044.   233 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 235
  4045. C
  4046.       WRITE(6,3007)
  4047.       WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
  4048.       STOP
  4049. C
  4050. C     UPDATE VARIABLES **
  4051. C
  4052.   235 ISUB=ISUB + 1
  4053.       INDEX=1
  4054.       YS1=YS2
  4055.       EET1=EET2
  4056.       YLD1=YLD2
  4057.       TMP1=TMP2
  4058. C
  4059.       DO 240 J=1,6
  4060.       EPS1(J)=EPS2(J)
  4061.       STRSS1(J)=STRSS2(J)
  4062.   240 EPSC1(J)=EPSC2(J)
  4063. C
  4064.       GO TO 60
  4065. C
  4066. C     AT END OF TIME STEP, CALCULATE YIELD STRESS USING DEFINITION
  4067. C     BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE PLASTIC STRAIN **
  4068. C
  4069.   245 YLDC=YS2
  4070.       IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
  4071. C
  4072.       GO TO 440
  4073. C
  4074. C        17. STRESS-TEMPERATURE STATE IS OUTSIDE THE YIELD
  4075. C            SURFACE---THERMO-ELASTIC-PLASTIC/CREEP BEHAVIOR
  4076. C
  4077. C            THERMO-ELASTIC-PLASTIC/CREEP STRESS CALCULATIONS
  4078. C            FOLLOW
  4079. C
  4080. C     CALCULATE THE FRACTION OF THE STRAIN SUBDIVISION OVER WHICH
  4081. C     THERE IS NO PLASTIC STRAINING **
  4082. C
  4083.   250 CALL EFST3(EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,STRSS1)
  4084. C
  4085. C     KINEMATIC HARDENING *
  4086. C
  4087.       IF(MODEL.EQ.10) GO TO 255
  4088. C
  4089.       SX1=SX1 - ALFA1(1)
  4090.       SY1=SY1 - ALFA1(2)
  4091.       SZ1=SZ1 - ALFA1(3)
  4092.       SXY1=SXY1 - ALFA1(4)
  4093.       SXZ1=SXZ1 - ALFA1(5)
  4094.       SYZ1=SYZ1 - ALFA1(6)
  4095. C
  4096.   255 RB=SX1*DX + SY1*DY + SZ1*DZ + 2.0*(SXY1*DXY + SXZ1*DXZ + SYZ1*DYZ)
  4097.       RD=SX1*SX1 + SY1*SY1 + SZ1*SZ1 + 2.0*(SXY1*SXY1 + SXZ1*SXZ1 +
  4098.      1   SYZ1*SYZ1)
  4099.       RE=RB - (XCON1*YLD1*DYLD)
  4100.       RF=RA - (XCON1*DYLD*DYLD)
  4101.       RG=RD - (XCON1*YLD1*YLD1)
  4102. C
  4103.       IF(IPELD.EQ.2.OR.RG.GE.0.0) GO TO 270
  4104. C
  4105. C     STRESS-TEMPERATURE STATE IS WITHIN THE YIELD SURFACE AT
  4106. C     START OF SUBDIVISION *
  4107. C
  4108.   260 IF(DABS(RF).GT.TOL5) GO TO 265
  4109.       RATIO=-RG/(2.0*RE)
  4110.       GO TO 275
  4111. C
  4112.   265 RATIO=(-RE + DSQRT(RE*RE - RF*RG))/RF
  4113.       GO TO 275
  4114. C
  4115. C     STRESS-TEMPERATURE STATE IS ON THE YIELD SURFACE AT START
  4116. C     OF SUBDIVISION *
  4117. C
  4118.   270 RATIO=0.0
  4119.       IF(RF.GT.TOL5.AND.RE.LT.0.0) RATIO=-2.0*RE/RF
  4120. C
  4121. C     CHECK CALCULATED VALUE OF RATIO **
  4122. C
  4123.   275 IF(RATIO.GE.(-TOL6) .AND. RATIO.LE.(1.0 + TOL6)) GO TO 280
  4124. C
  4125.       WRITE(6,3012)
  4126.       WRITE(6,3013) NEL,IPT,ISUB,TAU,IPELD,RA,RB,RD,RE,RF,RG,RATIO
  4127.       STOP
  4128. C
  4129.   280 IF(RATIO.GT.1.0) RATIO=1.0
  4130.       IF(RATIO.LT.0.0) RATIO=0.0
  4131.       IPELD=2
  4132. C
  4133. C        18. UPDATE ALL VARIABLES TO START OF YIELDING
  4134. C
  4135.       TAU=TAU + RATIO*DELT
  4136.       TMP1=TMPOLD + DELTMP*TAU/DTT
  4137.       YLD1=YLD1 + RATIO*DYLD
  4138.       IF(RATIO.GT.TOL5) ISUB=ISUB + 1
  4139.       IF(ISUB.GT.ISUBM) ISUBM=ISUBM + 1
  4140. C
  4141. C     CALCULATE STRESSES, TOTAL STRAINS, AND CREEP STRAINS AT
  4142. C     START OF YIELDING **
  4143. C
  4144.       DO 285 J=1,6
  4145.       EPS1(J)=EPS1(J) + RATIO*DEPS(J)
  4146.       EPSC1(J)=EPSC1(J) + RATIO*DPSC(J)
  4147.       EPSC2(J)=EPSC1(J)
  4148.       STRSS1(J)=STRSS1(J) + RATIO*DELSIG(J)
  4149.   285 STRSS2(J)=STRSS1(J)
  4150. C
  4151. C     CALCULATE MATERIAL PROPERTIES AT START OF YIELDING **
  4152. C
  4153.   288 CALL EMAT3(TMP1,PROP,PROP1,A1,B1,C1,D1,E1,F1,1)
  4154. C
  4155. C     CALCULATE THERMAL STRAINS AT START OF YIELDING **
  4156. C
  4157.       ALPHA1=PROP1(5)
  4158.       EPST1(1)=ALPHA1*(TMP1 - TREF)
  4159. C
  4160. C        19. CALCULATE SIZE OF FIRST SUBDIVISION AFTER YIELDING
  4161. C            (STRESS LOOP NO. 2)
  4162. C
  4163.   290 XNWDT=DTT - TAU
  4164.       DELT=XNWDT/DBLE(FLOAT(ISUBM - ISUB + 1))
  4165.       INDEX=1
  4166.       DEPSTR=0.0
  4167.       DESTR=1.0
  4168.       DENOM=0.0
  4169. C
  4170. C        20. CALCULATE TEMPERATURE AT END OF SUBDIVISION
  4171. C            AND WEIGHTED TEMPERATURE
  4172. C
  4173.   292 TMP2=TMPOLD + DELTMP*(TAU + DELT)/DTT
  4174.       TMPM=XPARM1*TMP1 + XPARM2*TMP2
  4175. C
  4176. C        21. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
  4177. C            CALCULATE WEIGHTED MATERIAL PROPERTIES
  4178. C
  4179.       CALL EMAT3(TMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
  4180. C
  4181.       DO 295 J=1,5
  4182.   295 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
  4183. C
  4184.       YMM=PROPM(1)
  4185.       ETM=PROPM(4)
  4186. C
  4187.       EETM=YMM*ETM/(YMM - ETM)
  4188.       CEM=XCON1*EETM
  4189. C
  4190. C        22. CALCULATE THERMAL STRAINS AT END OF SUBDIVISION
  4191. C            AND THERMAL STRAIN CHANGE FOR THE SUBDIVISION
  4192. C
  4193.       ALPHA2=PROP2(5)
  4194. C
  4195.       EPST2(1)=ALPHA2*(TMP2 - TREF)
  4196.       EPST2(2)=EPST2(1)
  4197.       EPST2(3)=EPST2(1)
  4198. C
  4199.       DPST=EPST2(1) - EPST1(1)
  4200. C
  4201. C        23. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
  4202. C            AND TOTAL STRAIN CHANGE FOR THE SUBDIVISION
  4203. C
  4204.   300 XFAC=(TAU + DELT)/DTT
  4205.       DO 305 J=1,6
  4206.       EPS2(J)=EPS(J) + XFAC*DELEPS(J)
  4207.   305 DEPS(J)=EPS2(J) - EPS1(J)
  4208. C
  4209. C        24. CALCULATE WEIGHTED STRESS
  4210. C
  4211.   310 DO 315 J=1,6
  4212.   315 STRSSM(J)=XPARM1*STRSS1(J) + XPARM2*STRSS2(J)
  4213. C
  4214.       CALL EFST3(ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,STRSSM)
  4215. C
  4216. C        25. CALCULATE WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
  4217. C
  4218.       EPSTRM=XPARM1*EPSTR1 + XPARM2*EPSTR2
  4219. C
  4220. C        26. CALCULATE WEIGHTED YIELD SURFACE TRANSLATION
  4221. C
  4222.       IF(MODEL.EQ.10) GO TO 320
  4223. C
  4224.       DO 318 J=1,6
  4225.   318 ALFAM(J)=XPARM1*ALFA1(J) + XPARM2*ALFA2(J)
  4226.       GO TO 324
  4227. C
  4228. C        27. CALCULATE WEIGHTED YIELD STRESS
  4229. C
  4230. C     ISOTROPIC HARDENING **
  4231. C
  4232.   320 YLDM=ESTM
  4233.       GO TO 328
  4234. C
  4235. C     KINEMATIC HARDENING **
  4236. C
  4237.   324 DO 325 J=1,6
  4238.   325 DSTSS(J)=STRSSM(J) - ALFAM(J)
  4239. C
  4240.       CALL EFST3(YLDM,SXT,SYT,SZT,SXYT,SXZT,SYZT,DSTSS)
  4241. C
  4242. C        28. PRELIMINARY CREEP CALCULATIONS
  4243. C
  4244.   328 IF(KCRP.EQ.0) GO TO 335
  4245. C
  4246.       DO 330 J=1,6
  4247.   330 DPSC(J)=0.0
  4248.       CRSRM=0.0
  4249. C
  4250.       DO 332 J=1,6
  4251.   332 EPSCM(J)=XPARM1*EPSC1(J) + XPARM2*EPSC2(J)
  4252. C
  4253.       CALL CREEP3(DELT,DPSC,TMPM,EPSCM,ORIGD,NORGD,STRSSM,
  4254.      1            GAMA,CRSRM,PTIME,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,
  4255.      2            FF,RR,GG,INDEX,ECSTRM)
  4256. C
  4257.       IF(INDEX.EQ.1) ECSTR1=ECSTRM
  4258. C
  4259. C        29. CALCULATE PLASTIC STRAINS AT END OF SUBDIVISION
  4260. C
  4261.   335 CALL EPMAT3(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
  4262.      1            PROP1,PROP2,PROPM,YLDM,1,A2,B2,C1,C2,DPSP,SXM,SYM,SZM,
  4263.      2            SXYM,SXZM,SYZM,INDEX,EETM)
  4264. C
  4265.   342 DO 344 J=1,6
  4266.   344 EPSP2(J)=EPSP1(J) + DPSP(J)
  4267. C
  4268.       IF(XLAMDA.LE.0.0) GO TO 345
  4269. C
  4270. C        30. CALCULATE ACCUMULATED EFFECTIVE PLASTIC STRAIN AT END
  4271. C            OF SUBDIVISION
  4272. C
  4273.       DEPSTR=DSQRT(XCON1*(DPSP(1)*DPSP(1) + DPSP(2)*DPSP(2) + DPSP(3)*
  4274.      1            DPSP(3)) + XCON2*(DPSP(4)*DPSP(4) + DPSP(5)*DPSP(5) +
  4275.      2            DPSP(6)*DPSP(6)))
  4276.       EPSTR2=EPSTR1 + DEPSTR
  4277. C
  4278. C        31. CALCULATE YIELD SURFACE TRANSLATION AT END
  4279. C            OF SUBDIVISION
  4280. C
  4281.       IF(MODEL.EQ.10) GO TO 345
  4282. C
  4283.       ALFA2(1)=ALFA1(1) + CEM*DPSP(1)
  4284.       ALFA2(2)=ALFA1(2) + CEM*DPSP(2)
  4285.       ALFA2(3)=ALFA1(3) + CEM*DPSP(3)
  4286.       ALFA2(4)=ALFA1(4) + 0.5*CEM*DPSP(4)
  4287.       ALFA2(5)=ALFA1(5) + 0.5*CEM*DPSP(5)
  4288.       ALFA2(6)=ALFA1(6) + 0.5*CEM*DPSP(6)
  4289. C
  4290. C        32. CALCULATE THE STRESSES AND CREEP STRAINS AT
  4291. C            END OF SUBDIVISION
  4292. C
  4293.   345 CALL SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
  4294.      1            CRSRM,FF,RR,GG,ESTM,SXM,SYM,SZM,SXYM,SXZM,SYZM,DELT,
  4295.      2            B2,C2,D2)
  4296. C
  4297. C        33. CHECK FOR CONVERGENCE OF ITERATION
  4298. C
  4299. C
  4300. C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK.EQ.0)
  4301. C     OR WHEN XPARM2 .EQ. 0.0 **
  4302. C
  4303.   350 IF(XPARM2.EQ.0.0) GO TO 400
  4304.       IF(ITCHK.EQ.1) GO TO 358
  4305. C
  4306.       INDEX=INDEX + 1
  4307.       IF(INDEX.LE.NITE) GO TO 310
  4308.       GO TO 400
  4309. C
  4310. C     CALCULATE EUCLIDEAN NORM OF THE CHANGE IN THE CURRENT
  4311. C     STRESS VECTOR **
  4312. C
  4313.   358 IF(INDEX - 4) 360,366,362
  4314. C
  4315.   360 INDEX=INDEX + 1
  4316.       GO TO 310
  4317. C
  4318.   362 DNORM2=0.0
  4319.       DO 365 J=1,6
  4320.   365 DNORM2=DNORM2 + (STRSS2(J) - STRSSD(J))*(STRSS2(J) - STRSSD(J))
  4321. C
  4322. C     CALCULATE EUCLIDEAN NORM OF THE CURRENT STRESS VECTOR **
  4323. C
  4324.   366 SNORM=0.0
  4325.       DO 368 J=1,6
  4326.   368 SNORM=SNORM + STRSS2(J)*STRSS2(J)
  4327. C
  4328. C     VALUE OF INDEX .LE. 5 **
  4329. C
  4330.       IF(INDEX.GT.5) GO TO 375
  4331.       SNORM2=SNORM
  4332.       IF(INDEX.EQ.4) SNORM1=SNORM2
  4333.       IF(INDEX.EQ.5) DNORM1=DNORM2
  4334.       INDEX=INDEX + 1
  4335. C
  4336.       DO 370 J=1,6
  4337.   370 STRSSD(J)=STRSS2(J)
  4338.       GO TO 310
  4339. C
  4340. C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
  4341. C
  4342. C
  4343. C     INITIAL CHECK FOR CONVERGENCE *
  4344. C
  4345.   375 IF(DNORM2.LE.DNORM1) GO TO 390
  4346. C
  4347. C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
  4348. C     TOLERANCE BAND
  4349. C
  4350.       XTOL=TOL3*SNORM1
  4351.       IF(SNORM1.LE.TOL2) XTOL=TOL2
  4352.       IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 400
  4353. C
  4354. C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
  4355. C     (NALG .EQ. 2) *
  4356. C
  4357.       DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
  4358.       IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 380
  4359. C
  4360.   378 WRITE(6,3008)
  4361.       WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
  4362.       STOP
  4363. C
  4364. C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE
  4365. C
  4366.   380 INDEX=1
  4367.       DEPSTR=0.0
  4368.       DESTR=1.0
  4369.       DENOM=0.0
  4370.       EPSTR2=EPSTR1
  4371. C
  4372.       DO 385 I=1,6
  4373.       STRSS2(I)=STRSS1(I)
  4374.       EPSP2(I)=EPSP1(I)
  4375.       ALFA2(I)=ALFA1(I)
  4376.   385 EPSC2(I)=EPSC1(I)
  4377. C
  4378.       GO TO 292
  4379. C
  4380. C     FINAL CHECK FOR CONVERGENCE *
  4381. C
  4382.   390 XTOL=TOL1*SNORM1
  4383.       IF(SNORM1.LE.TOL2) XTOL=TOL2
  4384.       IF(DNORM1.LE.XTOL) GO TO 400
  4385. C
  4386. C     NO CONVERGENCE
  4387. C
  4388.       INDEX=INDEX + 1
  4389.       IF(INDEX.LE.NITE) GO TO 395
  4390. C
  4391.       WRITE(6,3003)
  4392.       WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
  4393.       STOP
  4394. C
  4395.   395 DNORM1=DNORM2
  4396.       SNORM1=SNORM2
  4397.       SNORM2=SNORM
  4398. C
  4399.       DO 398 J=1,6
  4400.   398 STRSSD(J)=STRSS2(J)
  4401.       GO TO 310
  4402. C
  4403. C        34. CHECK SIZE OF INELASTIC STRAIN INCREMENT
  4404. C
  4405. C     CHECK IS BYPASSED WHEN THE EFFECTIVE INELASTIC STRAIN AT THE
  4406. C     START OF THE SUBDIVISION AND/OR THE EFFECTIVE INELASTIC STRAIN
  4407. C     RATE FOR THE SUBDIVISION .EQ. 0 **
  4408. C
  4409.   400 DECSTR=CRSRM*DELT
  4410.       DESTR=DECSTR + DEPSTR
  4411.       DENOM=ECSTR1 + EPSTR1
  4412.       IF(DESTR.LE.TOL5.OR.DENOM.LE.TOL5) GO TO 410
  4413. C
  4414.       CHECK=DESTR/(DENOM*TOLPC)
  4415.       IF(CHECK.LE.1.1) GO TO 410
  4416. C
  4417. C     INELASTIC STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
  4418. C     SUBDIVISION SIZE **
  4419. C
  4420.       DELT=DELT/CHECK
  4421.       IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 405
  4422. C
  4423.       WRITE(6,3009)
  4424.       WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
  4425.       STOP
  4426. C
  4427. C     RESET ARRAYS AND VARIABLES FOR NEW SUBDIVISION SIZE **
  4428. C
  4429.   405 INDEX=1
  4430.       DEPSTR=0.0
  4431.       DESTR=1.0
  4432.       DENOM=0.0
  4433.       EPSTR2=EPSTR1
  4434. C
  4435.       DO 408 I=1,6
  4436.       STRSS2(I)=STRSS1(I)
  4437.       EPSP2(I)=EPSP1(I)
  4438.       ALFA2(I)=ALFA1(I)
  4439.   408 EPSC2(I)=EPSC1(I)
  4440. C
  4441.       GO TO 292
  4442. C
  4443. C        35. CALCULATE YIELD STRESS AT END OF SUBDIVISION
  4444. C
  4445.   410 YM2=PROP2(1)
  4446.       ET2=PROP2(4)
  4447.       YS2=PROP2(3)
  4448. C
  4449.       EET2=YM2*ET2/(YM2 - ET2)
  4450. C
  4451. C     USING DEFINITION BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE
  4452. C     PLASTIC STRAIN **
  4453. C
  4454. C     KINEMATIC HARDENING *
  4455. C
  4456.       YLDC=YS2
  4457. C
  4458. C     ISOTROPIC HARDENING *
  4459. C
  4460.       IF(MODEL.EQ.10) YLDC=EET2*EPSTR2 + YLDC
  4461. C
  4462. C     USING STRESS STATE **
  4463. C
  4464. C     ISOTROPIC HARDENING *
  4465. C
  4466.       IF(MODEL.EQ.11) GO TO 412
  4467.       CALL EFST3(YLD2,SX2,SY2,SZ2,SXY2,SXZ2,SYZ2,STRSS2)
  4468.       GO TO 414
  4469. C
  4470. C     KINEMATIC HARDENING *
  4471. C
  4472.   412 DO 413 J=1,6
  4473.   413 DSTSS(J)=STRSS2(J) - ALFA2(J)
  4474. C
  4475.       CALL EFST3(YLD2,SXT,SYT,SZT,SXYT,SXZT,SYZT,DSTSS)
  4476. C
  4477. C        36. CORRECT STRESS STATE TO YIELD SURFACE
  4478. C
  4479. C     CHECK YIELD SURFACE ERROR **
  4480. C
  4481.   414 CHECK=DABS(YLD2 - YLDC)/DMIN1(YLD2,YLDC)
  4482.       IF(CHECK.LE.TOL7) GO TO 415
  4483. C
  4484.       WRITE(6,3014)
  4485.       WRITE(6,3015) NEL,IPT,ISUB,TAU,YLD2,YLDC
  4486.       STOP
  4487. C
  4488. C     *** THIS VERSION OF ADINA DOES NOT HAVE A CORRECTION FOR
  4489. C         ISOTHERMAL PERFECT PLASTICITY OR ISOTHERMAL KINEMATIC
  4490. C         HARDENING ***
  4491. C
  4492. C
  4493. C        37. UPDATE VARIABLES FOR NEXT SUBDIVISION
  4494. C
  4495.   415 TAU=TAU + DELT
  4496. C
  4497. C     CALCULATE SIZE OF NEXT SUBDIVISION **
  4498. C
  4499.       IF(NALG.EQ.2) GO TO 416
  4500. C
  4501. C     NALG .EQ. 1 *
  4502. C
  4503.       IF(ISUB.EQ.ISUBM) GO TO 440
  4504.       GO TO 425
  4505. C
  4506. C     NALG .EQ. 2 *
  4507. C
  4508.   416 IF(TAU.GE.TCHK) GO TO 440
  4509.       IF(DESTR.LE.TOL5) GO TO 420
  4510. C
  4511.       DELT=DELT*TOLPC*(1.0 + (DENOM/DESTR))
  4512.       IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
  4513.       GO TO 422
  4514. C
  4515.   420 DELT=DTT - TAU
  4516. C
  4517. C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
  4518. C     LARGE ENOUGH
  4519. C
  4520.   422 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 425
  4521. C
  4522.       WRITE(6,3010)
  4523.       WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
  4524.       STOP
  4525. C
  4526. C     UPDATE VARIABLES **
  4527. C
  4528.   425 ISUB=ISUB + 1
  4529.       INDEX=1
  4530.       DEPSTR=0.0
  4531.       DESTR=1.0
  4532.       DENOM=0.0
  4533.       TMP1=TMP2
  4534.       EPSTR1=EPSTR2
  4535.       EPST1(1)=EPST2(1)
  4536. C
  4537.       A1=A2
  4538.       B1=B2
  4539.       C1=C2
  4540.       D1=D2
  4541.       E1=E2
  4542.       F1=F2
  4543. C
  4544.       DO 430 J=1,6
  4545.       EPS1(J)=EPS2(J)
  4546.       STRSS1(J)=STRSS2(J)
  4547.       EPSC1(J)=EPSC2(J)
  4548.       ALFA1(J)=ALFA2(J)
  4549.   430 EPSP1(J)=EPSP2(J)
  4550. C
  4551.       DO 435 J=1,5
  4552.   435 PROP1(J)=PROP2(J)
  4553. C
  4554.       GO TO 292
  4555. C
  4556. C        38. PERMANENT UPDATING OF VARIABLES
  4557. C
  4558.   440 IF(IUPDT.NE.0) GO TO 455
  4559. C
  4560.       DO 445 J=1,6
  4561.       SIG(J)=STRSS2(J)
  4562.       ALFA(J)=ALFA2(J)
  4563.       EPSC(J)=EPSC2(J)
  4564.       EPSP(J)=EPSP2(J)
  4565.   445 EPS(J)=STRAIN(J)
  4566. C
  4567.       YLD=YLD2
  4568.       EPSTR=EPSTR2
  4569.       TMPOLD=TMP2
  4570.       IPEL=IPELD
  4571.       NORG=NORGD
  4572. C
  4573.       DO 450 I=1,6
  4574.       DO 450 J=1,2
  4575.   450 ORIG(I,J)=ORIGD(I,J)
  4576. C
  4577. C        39. CALCULATE LATEST CONSTITUTIVE LAW
  4578. C
  4579. C     CHECK FOR EQUILIBRIUM ITERATION **
  4580. C
  4581.   455 IF(ICOUNT.EQ.3) RETURN
  4582. C
  4583. C     CHECK FOR PRINTING OF STRESSES **
  4584. C
  4585.       IF(KPRI.EQ.0) GO TO 600
  4586. C
  4587. C     UPDATE SOLUTION VARIABLES **
  4588. C
  4589.       DO 458 J=1,6
  4590.       EPSC1(J)=EPSC2(J)
  4591.       EPSP1(J)=EPSP2(J)
  4592.       EPST1(J)=EPST2(J)
  4593.       STRSS1(J)=STRSS2(J)
  4594.   458 ALFA1(J)=ALFA2(J)
  4595. C
  4596.       YLD1=YLD2
  4597.       EPSTR1=EPSTR2
  4598. C
  4599. C     CALCULATE MATERIAL PROPERTIES AT END OF NEXT TIME STEP **
  4600. C
  4601.       A1=A2
  4602.       B1=B2
  4603.       C1=C2
  4604.       D1=D2
  4605.       E1=E2
  4606.       F1=F2
  4607. C
  4608.       DO 460 I=1,5
  4609.   460 PROP1(I)=PROP2(I)
  4610. C
  4611.       CALL EMAT3(TEMP2,PROP,PROP2,A2,B2,C2,D2,E2,F2,2)
  4612. C
  4613. C     CALCULATE THERMAL STRAINS AT END OF NEXT TIME STEP **
  4614. C
  4615.       ALPHA2=PROP2(5)
  4616.       EPST=ALPHA2*(TEMP2 - TREF)
  4617.       DPST=EPST - EPST1(1)
  4618. C
  4619.       DO 465 J=1,3
  4620.       EPST2(J)=EPST
  4621.   465 DEPST(J)=DPST
  4622. C
  4623. C     ESTIMATE CREEP STRAINS AT END OF NEXT TIME STEP **
  4624. C
  4625.       INDEX=1
  4626.       CALL EFST3(EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,STRSS1)
  4627. C
  4628.       IF(KCRP.EQ.0) GO TO 480
  4629. C
  4630.       DO 470 J=1,6
  4631.   470 DPSC(J)=0.0
  4632. C
  4633.       IF(EST1.LE.TOL5) GO TO 480
  4634.       TMPM=XPARM1*TEMP1 + XPARM2*TEMP2
  4635. C
  4636.       CALL CREEP3(DT,DPSC,TMPM,EPSC1,ORIGD,NORGD,STRSS1,GAMA,CRSR1,
  4637.      1            PTIME,EST1,SX1,SY1,SZ1,SXY1,SXZ1,SYZ1,FF,RR,GG,INDEX,
  4638.      2            ECSTR1)
  4639. C
  4640.       DO 475 I=1,6
  4641.   475 EPSC2(I)=EPSC1(I) + DPSC(I)
  4642. C
  4643. C     CHECK ELASTIC-PLASTIC INDICATOR **
  4644. C
  4645.   480 IF(IPELD.EQ.2) GO TO 490
  4646. C
  4647. C     THERMO-ELASTIC AND CREEP BEHAVIOR **
  4648. C
  4649.       DO 482 J=1,6
  4650.   482 STRESS(J)=0.0
  4651. C
  4652.       DO 485 I=1,6
  4653.       DO 485 J=1,6
  4654.   485 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J) -
  4655.      1          EPST2(J))
  4656. C
  4657.       RETURN
  4658. C
  4659. C     THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR **
  4660. C
  4661. C
  4662. C     CALCULATE WEIGHTED MATERIAL PROPERTIES *
  4663. C
  4664.   490 DO 494 J=1,5
  4665.   494 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
  4666. C
  4667. C     ESTIMATE PLASTIC STRAINS AT END OF NEXT TIME STEP *
  4668. C
  4669.   500 YMM=PROPM(1)
  4670.       ETM=PROPM(4)
  4671.       EETM=YMM*ETM/(YMM - ETM)
  4672. C
  4673.       CALL EPMAT3(STRSS1,ALFA1,EPSTR1,DELEPS,DPSC,DPST,CEP,XLAMDA,
  4674.      1            PROP1,PROP2,PROPM,YLD1,2,A2,B2,C1,C2,DPSP,SX1,SY1,SZ1,
  4675.      2            SXY1,SXZ1,SYZ1,INDEX,EETM)
  4676. C
  4677.       DO 505 J=1,6
  4678.       STRESS(J)=0.0
  4679.   505 EPSP2(J)=EPSP1(J) + DPSP(J)
  4680. C
  4681.       IF(IEQREF.EQ.1 .OR. XLAMDA.LT.0.0) GO TO 520
  4682. C
  4683. C     ITERATION WITH ELASTIC-PLASTIC STIFFNESS MATRIX *
  4684. C
  4685.       DO 510 I=1,6
  4686.       DO 510 J=1,6
  4687.   510 STRESS(I)=STRESS(I) - CEP(I,J)*(DPSC(J) + DEPST(J)) + C(I,J)*
  4688.      1          (STRAIN(J) - EPSP1(J) - EPSC1(J) - EPST1(J) - DPSP(J))
  4689. C
  4690.       DO 515 I=1,6
  4691.       DO 515 J=1,6
  4692.   515 C(I,J)=CEP(I,J)
  4693. C
  4694.       RETURN
  4695. C
  4696. C     ITERATION WITH ELASTIC STIFFNESS MATRIX WHEN GLOBAL DIVERGENCE
  4697. C     PROCEDURE IS ACTIVATED OR UNLOADING IS DETECTED *
  4698. C
  4699.   520 DO 535 I=1,6
  4700.       DO 535 J=1,6
  4701.   535 STRESS(I)=STRESS(I) + C(I,J)*(STRAIN(J) - EPSP2(J) - EPSC2(J)
  4702.      1          - EPST2(J))
  4703. C
  4704.       RETURN
  4705. C
  4706. C        40. PRINTING OF STRESSES
  4707. C
  4708. C     CALCULATE EFFECTIVE STRESS **
  4709. C
  4710.   600 FT=YLD2
  4711.       IF(IPELD.EQ.1) FT=DSQRT(1.5*FTA)
  4712. C
  4713. C     IN TOTAL LAGRANGIAN FORMULATION, CALCULATE CAUCHY STRESSES **
  4714. C
  4715.   605 IF(INDNL.EQ.2) CALL CAUCH3
  4716. C
  4717.   610 IF(IPRI.NE.0) RETURN
  4718.       IF (IPS.LT.0) GO TO 700
  4719. C
  4720. C     STRESS PRINTOUT ONLY **
  4721. C
  4722.       IF(IPT.GT.1) GO TO 620
  4723. C
  4724. C     PRINT HEADING *
  4725. C
  4726.       WRITE(6,2000)
  4727. C
  4728. C     PRINT ELEMENT NUMBER *
  4729. C
  4730.       WRITE(6,2005) NEL
  4731. C
  4732. C     PRINT INTEGRATION POINT STRESSES *
  4733. C
  4734.   620 WRITE(6,2200) IPT,STATE(IPELD),(STRSS2(J),J=1,6)
  4735.       WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
  4736. C
  4737.       RETURN
  4738. C
  4739. C     STRESS AND STRAIN PRINTOUT **
  4740. C
  4741.   700 IF(IPT.GT.1) GO TO 720
  4742. C
  4743. C     PRINT HEADING *
  4744. C
  4745.       WRITE(6,2000)
  4746. C
  4747. C     PRINT ELEMENT NUMBER *
  4748. C
  4749.       WRITE(6,2005) NEL
  4750. C
  4751. C     PRINT INTEGRATION POINT STRESSES AND STRAINS *
  4752. C
  4753.   720 WRITE(6,2200) IPT,STATE(IPELD),(STRSS2(J),J=1,6)
  4754.       WRITE(6,2300) (STRAIN(J),J=1,6)
  4755.       WRITE(6,2400) (EPSP2(J),J=1,6)
  4756.       WRITE(6,2500) (EPSC2(J),J=1,6)
  4757.       WRITE(6,2600) (EPST2(J),J=1,6)
  4758.       WRITE(6,2700) TEMP2,EPSTR2,ISUB,FT,YLD2,YLDC
  4759. C
  4760.       RETURN
  4761. C
  4762.  2000 FORMAT (1X,7HELEMENT,2X,6HSTRESS,4X,13HSTRESS/STRAIN,8X,2HXX,
  4763.      1        13X,2HYY,13X,2HZZ,13X,2HXY,13X,2HXZ,13X,2HYZ,/,1X,
  4764.      2        7HNUM/IPT,3X,5HSTATE,4X,10HCOMPONENTS)
  4765.  2005 FORMAT (/,1X,I3)
  4766.  2200 FORMAT (6X,I2,2X,A2,6HLASTIC,2X,6HSTRESS,9X,6(E14.6,1X))
  4767.  2300 FORMAT (20X,12HSTRAIN-TOTAL,3X,6(E14.6,1X))
  4768.  2400 FORMAT (25X,7HPLASTIC,3X,6(E14.6,1X))
  4769.  2500 FORMAT (27X,5HCREEP,3X,6(E14.6,1X))
  4770.  2600 FORMAT (25X,7HTHERMAL,3X,6(E14.6,1X))
  4771.  2700 FORMAT (20X,14HTEMPERATURE = ,E14.6,1X,
  4772.      1        29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,1X,
  4773.      2        25HNUMBER OF SUBDIVISIONS = ,I5,/,20X,
  4774.      3        12HEFF STRESS = ,E14.6,1X,
  4775.      4        13HYLD STRESS = ,E14.6,1X,
  4776.      5        41HYLD STRESS(TMP.,ACC. EFF. PLAS. STRN.) = ,E14.6,/)
  4777.  3001 FORMAT(//,68H    ERROR   STRESS LOOP NO. 1 FAILED TO CONVERGE   (S
  4778.      1UBROUTINE EPC3))
  4779.  3002 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
  4780.      1       13HSUBDIVISION = ,I5,/,5X,
  4781.      2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
  4782.      3       40HAPPROXIMATE REQUIRED SUBDIVISION SIZE = ,E14.6)
  4783.  3003 FORMAT(//,68H    ERROR   STRESS LOOP NO. 2 FAILED TO CONVERGE   (S
  4784.      1UBROUTINE EPC3))
  4785.  3004 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
  4786.      1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBROUTINE EPC3))
  4787.  3006 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
  4788.      1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBRO
  4789.      2UTINE EPC3))
  4790.  3007 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
  4791.      1REACH END OF TIME STEP IN STRESS LOOP NO. 1   (SUBROUTINE EPC3))
  4792.  3008 FORMAT(//,115H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
  4793.      1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBROUTINE EPC3))
  4794.  3009 FORMAT(//,129H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
  4795.      1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBRO
  4796.      2UTINE EPC3))
  4797.  3010 FORMAT(//,115H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
  4798.      1REACH END OF TIME STEP IN STRESS LOOP NO. 2   (SUBROUTINE EPC3))
  4799.  3011 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
  4800.      1       14HSUBDIVISION = ,I5,/,5X,
  4801.      2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
  4802.      3       24HLAST SUBDIVISION SIZE = ,E14.6)
  4803.  3012 FORMAT(//,70H    ERROR   INCORRECT VALUE CALCULATED FOR *RATIO*
  4804.      1(SUBROUTINE EPC3))
  4805.  3013 FORMAT(//,5X,10HELEMENT = ,I5,1X,20HINTEGRATION POINT = ,I5,1X,
  4806.      1       14HSUBDIVISION = ,I5,1X,
  4807.      2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,1X,
  4808.      3        7HIPEL = ,I2,/,5X,
  4809.      4        5HRA = ,E14.6,1X,5HRB = ,E14.6,1X,5HRD = ,E14.6,
  4810.      5        5HRE = ,E14.6,1X,5HRF = ,E14.6,1X,5HRG = ,E14.6,/,5X,
  4811.      6        8HRATIO = ,E14.6,//)
  4812.  3014 FORMAT(//,101H    ERROR   DIFFERENCE BETWEEN THE TWO MEASURES OF Y
  4813.      1IELD STRESS EXCEEDS TOLERANCE   (SUBROUTINE EPC3))
  4814.  3015 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
  4815.      1       14HSUBDIVISION = ,I5,2X,
  4816.      2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,/,5X,
  4817.      3       35HYIELD STRESS (FROM STRESS STATE) = ,E14.6,2X,
  4818.      4       54HYIELD STRESS (FROM TEMPERATURE AND ACCUM. EFF. PLASTIC,
  4819.      5       10HSTRAIN) = ,E14.6,//)
  4820. C
  4821.       END
  4822. C *CDC* *DECK SIGMA3
  4823. C *UNI* )FOR,IS  N.SIGMA3, R.SIGMA3
  4824. C
  4825.       SUBROUTINE SIGMA3(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,
  4826.      1                  PTIME,STRNR,F,R,G,EST,SX,SY,SZ,SXY,SXZ,SYZ,
  4827.      2                  DELT,XB2,XC2,XD2)
  4828. C
  4829. C
  4830. C
  4831. C     THIS SUBROUTINE USES A NEWTON-RAPHSON METHOD TO CALCULATE
  4832. C     STRESSES AND CREEP STRAINS
  4833. C
  4834. C
  4835. C
  4836.       IMPLICIT REAL*8 (A-H,O-Z)
  4837. C
  4838.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  4839.      1              TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  4840.      2              SUBDD,RNGL,RNGU,DTT,TOL7,
  4841.      3              KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  4842.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  4843. C
  4844.       DIMENSION STRSS2(1),EPS2(1),EPSP2(1),EPST2(1),EPSC1(1),EPSC2(1),
  4845.      1          DPSC(1),TSTRSS(6),RH(6),TC(6,6),TTC(6,6)
  4846. C
  4847. C
  4848. C
  4849. C
  4850.       DO 10 J=1,6
  4851.       TSTRSS(J)=STRSS2(J)
  4852.    10 RH(J)=0.0
  4853. C
  4854.       DO 20 I=1,6
  4855.       DO 20 J=1,6
  4856.    20 TC(I,J)=0.0
  4857. C
  4858. C        1. FORM FIRST PART OF R.H.S. VECTOR
  4859. C
  4860.       DO 25 I=1,6
  4861.       DO 25 J=1,6
  4862.    25 RH(I)=RH(I) + C(I,J)*(EPS2(J) - EPSP2(J) - EPSC1(J) - DPSC(J)
  4863.      1      - EPST2(J))
  4864. C
  4865.       IF(XPARM2.GT.0.0.AND.KCRP.GT.0.AND.EST.GT.TOL5) GO TO 35
  4866. C
  4867.       DO 30 I=1,6
  4868.       EPSC2(I)=EPSC1(I) + DPSC(I)
  4869.    30 STRSS2(I)=RH(I)
  4870. C
  4871.       RETURN
  4872. C
  4873. C        2. FORM THE PART OF THE ITERATION MATRIX USED TO CALCULATE
  4874. C           THE R.H.S. VECTOR AND THE CREEP STRAIN INCREMENT
  4875. C
  4876.    35 A0=CRPCON(1)
  4877.       A1=CRPCON(2)
  4878.       A2=CRPCON(3)
  4879.       A3=CRPCON(4)
  4880.       A4=CRPCON(5)
  4881.       A5=CRPCON(6)
  4882.       A6=CRPCON(7)
  4883. C
  4884.       IF(KCRP.EQ.2) GO TO 40
  4885. C
  4886. C     CREEP LAW NO. 1 **
  4887. C
  4888.       GG=1.5*(A1 - A2)*GAMA/(A2*EST*EST)
  4889.       GO TO 50
  4890. C
  4891. C     CREEP LAW NO. 2 **
  4892. C
  4893.    40 C2=A4 - 1.0
  4894.       C1=1.5*A2*A4*(A3**(-A4))
  4895.       C3=1.5*A1
  4896.       C4=1.5*A6
  4897. C
  4898.       D1=DEXP(-R*PTIME)*F
  4899.       D2=EST**C2
  4900. C
  4901.       DTPSP=(D1*(C3 - PTIME*C1*D2) - C3*F - PTIME*C4*G)/STRNR
  4902. C
  4903.       GG=(1.5*D1*(C1*D2 - R*(PTIME*C1*D2 + R*DTPSP - C3)) + 1.5*C4*G -
  4904.      1   1.5*GAMA)/(EST*EST)
  4905. C
  4906.    50 COEF=2.0*XC2*XPARM2*DELT
  4907. C
  4908.       TC(1,1)=COEF*(GG*SX*SX + XCON1*GAMA)
  4909.       TC(1,2)=COEF*(GG*SX*SY - XCON2*GAMA)
  4910.       TC(1,3)=COEF*(GG*SX*SZ - XCON2*GAMA)
  4911.       TC(1,4)=COEF*(2.0*GG*SX*SXY)
  4912.       TC(1,5)=COEF*(2.0*GG*SX*SXZ)
  4913.       TC(1,6)=COEF*(2.0*GG*SX*SYZ)
  4914. C
  4915.       TC(2,1)=TC(1,2)
  4916.       TC(2,2)=COEF*(GG*SY*SY + XCON1*GAMA)
  4917.       TC(2,3)=COEF*(GG*SY*SZ - XCON2*GAMA)
  4918.       TC(2,4)=COEF*(2.0*GG*SY*SXY)
  4919.       TC(2,5)=COEF*(2.0*GG*SY*SXZ)
  4920.       TC(2,6)=COEF*(2.0*GG*SY*SYZ)
  4921. C
  4922.       TC(3,1)=TC(1,3)
  4923.       TC(3,2)=TC(2,3)
  4924.       TC(3,3)=COEF*(GG*SZ*SZ + XCON1*GAMA)
  4925.       TC(3,4)=COEF*(2.0*GG*SZ*SXY)
  4926.       TC(3,5)=COEF*(2.0*GG*SZ*SXZ)
  4927.       TC(3,6)=COEF*(2.0*GG*SZ*SYZ)
  4928. C
  4929.       TC(4,1)=TC(1,4)
  4930.       TC(4,2)=TC(2,4)
  4931.       TC(4,3)=TC(3,4)
  4932.       TC(4,4)=COEF*(2.0*GG*SXY*SXY + GAMA)
  4933.       TC(4,5)=COEF*(2.0*GG*SXY*SXZ)
  4934.       TC(4,6)=COEF*(2.0*GG*SXY*SYZ)
  4935. C
  4936.       TC(5,1)=TC(1,5)
  4937.       TC(5,2)=TC(2,5)
  4938.       TC(5,3)=TC(3,5)
  4939.       TC(5,4)=TC(4,5)
  4940.       TC(5,5)=COEF*(2.0*GG*SXZ*SXZ + GAMA)
  4941.       TC(5,6)=COEF*(2.0*GG*SXZ*SYZ)
  4942. C
  4943.       TC(6,1)=TC(1,6)
  4944.       TC(6,2)=TC(2,6)
  4945.       TC(6,3)=TC(3,6)
  4946.       TC(6,4)=TC(4,6)
  4947.       TC(6,5)=TC(5,6)
  4948.       TC(6,6)=COEF*(2.0*GG*SYZ*SYZ + GAMA)
  4949. C
  4950.       DO 55 I=1,6
  4951.       DO 55 J=1,6
  4952.    55 TTC(I,J)=TC(I,J)/(2.0*XC2)
  4953. C
  4954. C        3. FORM ITERATION MATRIX AND SECOND PART OF R.H.S. VECTOR
  4955. C
  4956.    80 DO 95 I=1,6
  4957.       DO 95 J=1,6
  4958.    95 RH(I)=RH(I) + TC(I,J)*STRSS2(J)
  4959. C
  4960.       DO 110 J=1,6
  4961.   110 TC(J,J)=TC(J,J) + 1.0
  4962. C
  4963. C        4. CALCULATE STRESSES AT END OF SUBDIVISION
  4964. C
  4965.       CALL EQSOL3(TC,RH,1,6)
  4966. C
  4967.       DO 130 J=1,6
  4968.   130 STRSS2(J)=RH(J)
  4969. C
  4970. C        5. CALCULATE CREEP STRAINS AT END OF SUBDIVISION
  4971. C
  4972.       DO 160 I=1,6
  4973.       DO 150 J=1,6
  4974.   150 DPSC(I)=DPSC(I) + TTC(I,J)*(STRSS2(J) - TSTRSS(J))
  4975.   160 EPSC2(I)=EPSC1(I) + DPSC(I)
  4976. C
  4977.       RETURN
  4978. C
  4979.       END
  4980. C *CDC* *DECK EQSOL3
  4981. C *UNI* )FOR,IS  N.EQSOL3, R.EQSOL3
  4982. C
  4983.       SUBROUTINE EQSOL3(A,R,KEY,N)
  4984. C
  4985. C
  4986. C
  4987. C     THIS SUBROUTINE SOLVES A SYSTEM OF LINEAR ALGEBRAIC
  4988. C     EQUATIONS USING GAUSSIAN ELIMINATION WITH COMPLETE PIVOTING
  4989. C
  4990. C     THE ROW MULTIPLIERS ARE STORED IN THE LOWER TRIANGULAR PART OF
  4991. C     THE REDUCED COEFFICIENT MATRIX
  4992. C
  4993. C     THE SOLUTION VARIABLES ARE RETURNED IN THE R.H.S. VECTOR
  4994. C
  4995. C     THE FOLLOWING VARIABLES ARE USED
  4996. C        A = COEFFICIENT MATRIX
  4997. C        R = R.H.S. VECTOR
  4998. C        N = NUMBER OF EQUATIONS
  4999. C        KEY = CONTROL VARIABLE
  5000. C            = 1 COMPLETE SOLUTION
  5001. C            = 2 R.H.S. REDUCTION AND BACK-SUBSTITUTION
  5002. C
  5003. C
  5004. C
  5005.       IMPLICIT REAL*8 (A-H,O-Z)
  5006. C
  5007.       DIMENSION A(6,6),R(6),ICOL(6),TR(6),IROW(6)
  5008. C
  5009. C
  5010. C
  5011.       EPS=1.0D-50
  5012.       NN=N-1
  5013.       IF(KEY.EQ.2) GO TO 110
  5014. C
  5015.       DO 10 I=1,N
  5016.       IROW(I)=I
  5017.    10 ICOL(I)=I
  5018. C
  5019.       DO 100 J=1,NN
  5020. C
  5021. C        1. SEARCH FOR LARGEST PIVOT
  5022. C
  5023.       PIVI=0.0
  5024.       DO 20 I=J,N
  5025.       DO 20 K=J,N
  5026.       IF(DABS(A(I,K)).LE.DABS(PIVI)) GO TO 20
  5027.       IMAX=I
  5028.       KMAX=K
  5029.       PIVI=A(I,K)
  5030.    20 CONTINUE
  5031. C
  5032.       IF(DABS(PIVI).GT.EPS) GO TO 25
  5033.       WRITE(6,7000)
  5034.       WRITE(6,7010) J
  5035.       STOP
  5036. C
  5037. C        2. INTERCHANGE COLUMNS
  5038. C
  5039.    25 IF(KMAX.EQ.J) GO TO 40
  5040. C
  5041.       ISAVE=ICOL(KMAX)
  5042.       ICOL(KMAX)=ICOL(J)
  5043.       ICOL(J)=ISAVE
  5044. C
  5045.       DO 30 JJ=1,N
  5046.       SAVE=A(JJ,KMAX)
  5047.       A(JJ,KMAX)=A(JJ,J)
  5048.    30 A(JJ,J)=SAVE
  5049. C
  5050. C        3. INTERCHANGE ROWS
  5051. C
  5052.    40 IF(IMAX.EQ.J) GO TO 85
  5053. C
  5054.       ISAVE=IROW(IMAX)
  5055.       IROW(IMAX)=IROW(J)
  5056.       IROW(J)=ISAVE
  5057. C
  5058.       DO 50 K=1,N
  5059.       SAVE=A(J,K)
  5060.       A(J,K)=A(IMAX,K)
  5061.    50 A(IMAX,K)=SAVE
  5062. C
  5063.       SAVE=R(J)
  5064.       R(J)=R(IMAX)
  5065.       R(IMAX)=SAVE
  5066. C
  5067. C        4. REDUCE COEFFICIENT MATRIX AND STORE MULTIPLIERS
  5068. C
  5069.    85 I2=J + 1
  5070.       DO 90 K2=I2,N
  5071.       XMULT=A(K2,J)/PIVI
  5072.       A(K2,J)=XMULT
  5073.       DO 90 J2=I2,N
  5074.    90 A(K2,J2)=A(K2,J2) - XMULT*A(J,J2)
  5075. C
  5076.   100 CONTINUE
  5077.       GO TO 150
  5078. C
  5079. C        5. REDUCE R.H.S. VECTOR
  5080. C
  5081. C     FOR KEY = 2, REORDER R.H.S. VECTOR **
  5082. C
  5083.   110 DO 120 J=1,N
  5084.       K=IROW(J)
  5085.   120 TR(J)=R(K)
  5086. C
  5087.       DO 130 J=1,N
  5088.   130 R(J)=TR(J)
  5089. C
  5090.   150 DO 200 J=1,NN
  5091.       I2=J + 1
  5092.       DO 200 K2=I2,N
  5093.       XMULT=A(K2,J)
  5094.   200 R(K2)=R(K2) - XMULT*R(J)
  5095. C
  5096. C        6. BACK-SUBSTITUTION
  5097. C
  5098.       DO 320 I=1,N
  5099.       TSUM=0.0
  5100.       II=N + 1 - I
  5101.       IF(II.EQ.N) GO TO 315
  5102.       JJ=II + 1
  5103. C
  5104.       DO 310 K=JJ,N
  5105.   310 TSUM=TSUM + A(II,K)*R(K)
  5106. C
  5107.   315 R(II)=(R(II) - TSUM)/A(II,II)
  5108.   320 CONTINUE
  5109. C
  5110. C        7. REORDER VARIABLES TO ACCOUNT FOR PIVOTING
  5111. C
  5112.       DO 330 J=1,N
  5113.       K=ICOL(J)
  5114.   330 TR(K)=R(J)
  5115. C
  5116.       DO 340 J=1,N
  5117.   340 R(J)=TR(J)
  5118. C
  5119.       RETURN
  5120. C
  5121.  7000 FORMAT(///,64H   ERROR   UNABLE TO OBTAIN NON-ZERO PIVOT   (SUBROU
  5122.      1TINE EQSOL3))
  5123.  7010 FORMAT(/,10X,15HPIVOT NUMBER = ,I5)
  5124. C
  5125.       END
  5126. C *CDC* *DECK EFST3
  5127. C *UNI* )FOR,IS  N.EFST3, R.EFST3
  5128. C
  5129.       SUBROUTINE EFST3(EST,SX,SY,SZ,SXY,SXZ,SYZ,STRESS)
  5130. C
  5131. C
  5132. C
  5133. C     THIS SUBROUTINE CALCULATES THE DEVIATORIC STRESS
  5134. C     COMPONENTS AND THE EFFECTIVE STRESS
  5135. C
  5136. C
  5137. C
  5138.       IMPLICIT REAL*8 (A-H,O-Z)
  5139. C
  5140.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5141.      1                TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5142.      2                SUBDD,RNGL,RNGU,DTT,TOL7,
  5143.      3                KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5144. C
  5145.       DIMENSION STRESS(6)
  5146. C
  5147. C
  5148. C
  5149.       SM=(STRESS(1) + STRESS(2) + STRESS(3))*XCON2
  5150. C
  5151.       SX=STRESS(1)-SM
  5152.       SY=STRESS(2)-SM
  5153.       SZ=STRESS(3)-SM
  5154.       SXY=STRESS(4)
  5155.       SXZ=STRESS(5)
  5156.       SYZ=STRESS(6)
  5157. C
  5158.       EST=DSQRT(1.5*(SX*SX + SY*SY + SZ*SZ + 2.0*(SXY*SXY + SXZ*SXZ +
  5159.      1         SYZ*SYZ)))
  5160. C
  5161.       RETURN
  5162. C
  5163.       END
  5164. C *CDC* *DECK EPMAT3
  5165. C *UNI* )FOR,IS  N.EPMAT3, R.EPMAT3
  5166. C
  5167.       SUBROUTINE EPMAT3(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,CEP,XLAMDA,
  5168.      1                  PROP1,PROP2,PROPM,YLDM,KEY,A2,B2,C1,C2,DPSP,
  5169.      2                  SXM,SYM,SZM,SXYM,SXZM,SYZM,INDEX,EETM)
  5170. C
  5171. C
  5172. C     THIS SUBROUTINE CALCULATES PLASTIC STRAIN INCREMENTS AND THE
  5173. C     ELASTIC-PLASTIC CONSTITUTIVE MATRIX
  5174. C
  5175. C
  5176. C
  5177. C     KEY = 1  CALCULATE PLASTIC STRAIN INCREMENTS
  5178. C              (STRESS CALCULATIONS)
  5179. C         = 2  CALCULATE PLASTIC STRAIN INCREMENTS AND
  5180. C              ELASTIC-PLASTIC CONSTITUTIVE MATRIX
  5181. C              (FORMING STIFFNESS MATRIX)
  5182. C
  5183. C
  5184. C
  5185.       IMPLICIT REAL*8 (A-H,O-Z)
  5186. C
  5187.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  5188.      1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  5189.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  5190.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  5191.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  5192.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5193.      1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5194.      2               SUBDD,RNGL,RNGU,DTT,TOL7,
  5195.      3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5196.       COMMON /TPLAS3/ EETD,PRM,CM,CD,YSD
  5197. C
  5198.       DIMENSION STRSSM(1),ALFAM(1),DEPS(1),DPSC(1),PROP1(1),
  5199.      1          PROP2(1),PROPM(1),CEP(6,6),DPSP(6)
  5200. C
  5201.       EQUIVALENCE (NPAR(15),MODEL)
  5202. C
  5203. C
  5204. C
  5205. C
  5206. C        1. INITIALIZE VARIABLES
  5207. C
  5208.       SXT=SXM
  5209.       SYT=SYM
  5210.       SZT=SZM
  5211.       SXYT=SXYM
  5212.       SXZT=SXZM
  5213.       SYZT=SYZM
  5214. C
  5215.       IF(INDEX.GT.1) GO TO 40
  5216. C
  5217.       YMM=PROPM(1)
  5218.       PRM=PROPM(2)
  5219.       ETM=PROPM(4)
  5220. C
  5221.       YMD=PROP2(1) - PROP1(1)
  5222.       PRD=PROP2(2) - PROP1(2)
  5223.       ETD=PROP2(4) - PROP1(4)
  5224.       YSD=PROP2(3) - PROP1(3)
  5225. C
  5226.       CD=C2 - C1
  5227.       CM=0.5*YMM/(1.0 + PRM)
  5228.       EETD=((YMM*YMM*ETD) - (ETM*ETM*YMD))/((YMM - ETM)*(YMM - ETM))
  5229. C
  5230. C        2. CALCULATE PLASTIC STRAIN INCREMENT
  5231. C
  5232. C     KINEMATIC HARDENING **
  5233. C
  5234.    40 IF(MODEL.EQ.10) GO TO 50
  5235. C
  5236.       SXM=SXM - ALFAM(1)
  5237.       SYM=SYM - ALFAM(2)
  5238.       SZM=SZM - ALFAM(3)
  5239.       SXYM=SXYM - ALFAM(4)
  5240.       SXZM=SXZM - ALFAM(5)
  5241.       SYZM=SYZM - ALFAM(6)
  5242. C
  5243.    50 WP1=CM*(SXM*(DEPS(1) - DPSC(1) - DPST) + SYM*(DEPS(2) - DPSC(2) -
  5244.      1   DPST) + SZM*(DEPS(3) - DPSC(3) - DPST) + SXYM*(DEPS(4) -
  5245.      2   DPSC(4)) + SXZM*(DEPS(5) - DPSC(5)) + SYZM*(DEPS(6) -
  5246.      3   DPSC(6)))
  5247.  
  5248. C
  5249.       WP2=(0.5*CD/CM)*(SXM*STRSSM(1) + SYM*STRSSM(2) + SZM*STRSSM(3)
  5250.      1     + 2.0*(SXYM*STRSSM(4) + SXZM*STRSSM(5) + SYZM*STRSSM(6)))
  5251. C
  5252.       DENMP=(XCON1*YLDM*YLDM)*(CM + EETM*XCON2)
  5253. C
  5254.    60 WP=WP1 + WP2
  5255. C
  5256.       IF(MODEL.EQ.11) GO TO 65
  5257. C
  5258. C     ISOTROPIC HARDENING *
  5259. C
  5260.       XLAMDA=(WP - (YLDM*XCON2)*(EPSTRM*EETD + YSD))/DENMP
  5261.       WPP=XLAMDA
  5262.       GO TO 70
  5263. C
  5264. C     KINEMATIC HARDENING *
  5265. C
  5266.    65 XLAMDA=(WP - (YLDM*YSD*XCON2))/DENMP
  5267.       WPP=XLAMDA
  5268. C
  5269. C     CHECK FOR UNLOADING OR NEUTRAL LOADING **
  5270. C
  5271.    70 IF(XLAMDA.GT.0.0) GO TO 75
  5272.       XLAMDA=0.0
  5273.       GO TO 80
  5274. C
  5275.    75 IF(KEY.EQ.2 .AND. IEQREF.NE.1) XLAMDA=XLAMDA - WP1/DENMP
  5276. C
  5277.    80 DPSP(1)=XLAMDA*SXM
  5278.       DPSP(2)=XLAMDA*SYM
  5279.       DPSP(3)=XLAMDA*SZM
  5280.       DPSP(4)=2.0*XLAMDA*SXYM
  5281.       DPSP(5)=2.0*XLAMDA*SXZM
  5282.       DPSP(6)=2.0*XLAMDA*SYZM
  5283. C
  5284.       XLAMDA=WPP
  5285. C
  5286.       IF(KEY.EQ.2 .AND. IEQREF.NE.1 .AND. XLAMDA.GE.0.0) GO TO 90
  5287. C
  5288.       SXM=SXT
  5289.       SYM=SYT
  5290.       SZM=SZT
  5291.       SXYM=SXYT
  5292.       SXZM=SXZT
  5293.       SYZM=SYZT
  5294. C
  5295.       RETURN
  5296. C
  5297. C        3. CALCULATE ELASTIC-PLASTIC CONSTITUTIVE MATRIX
  5298. C
  5299.    90 YLD1=YLDM
  5300. C
  5301.       SX1=SXM
  5302.       SY1=SYM
  5303.       SZ1=SZM
  5304.       SXY1=SXYM
  5305.       SXZ1=SXZM
  5306.       SYZ1=SYZM
  5307. C
  5308.       YIELD=YLD1*YLD1/(3.0*C2)
  5309.       GAMA1=1.0/(YIELD*(1.0 + EETM/(3.0*CM)))
  5310. C
  5311.       GAMA=GAMA1*SX1
  5312.       CEP(1,1)=A2 - GAMA*SX1
  5313.       CEP(1,2)=B2 - GAMA*SY1
  5314.       CEP(1,3)=B2 - GAMA*SZ1
  5315.       CEP(1,4)=   - GAMA*SXY1
  5316.       CEP(1,5)=   - GAMA*SXZ1
  5317.       CEP(1,6)=   - GAMA*SYZ1
  5318. C
  5319.       GAMA=GAMA1*SY1
  5320.       CEP(2,1)=CEP(1,2)
  5321.       CEP(2,2)=A2 - GAMA*SY1
  5322.       CEP(2,3)=B2 - GAMA*SZ1
  5323.       CEP(2,4)=   - GAMA*SXY1
  5324.       CEP(2,5)=   - GAMA*SXZ1
  5325.       CEP(2,6)=   - GAMA*SYZ1
  5326. C
  5327.       GAMA=GAMA1*SZ1
  5328.       CEP(3,1)=CEP(1,3)
  5329.       CEP(3,2)=CEP(2,3)
  5330.       CEP(3,3)=A2 - GAMA*SZ1
  5331.       CEP(3,4)=   - GAMA*SXY1
  5332.       CEP(3,5)=   - GAMA*SXZ1
  5333.       CEP(3,6)=   - GAMA*SYZ1
  5334. C
  5335.       GAMA=GAMA1*SXY1
  5336.       CEP(4,1)=CEP(1,4)
  5337.       CEP(4,2)=CEP(2,4)
  5338.       CEP(4,3)=CEP(3,4)
  5339.       CEP(4,4)=C2 - GAMA*SXY1
  5340.       CEP(4,5)=   - GAMA*SXZ1
  5341.       CEP(4,6)=   - GAMA*SYZ1
  5342. C
  5343.       GAMA=GAMA1*SXZ1
  5344.       CEP(5,1)=CEP(1,5)
  5345.       CEP(5,2)=CEP(2,5)
  5346.       CEP(5,3)=CEP(3,5)
  5347.       CEP(5,4)=CEP(4,5)
  5348.       CEP(5,5)=C2 - GAMA*SXZ1
  5349.       CEP(5,6)=   - GAMA*SYZ1
  5350. C
  5351.       GAMA=GAMA1*SYZ1
  5352.       CEP(6,1)=CEP(1,6)
  5353.       CEP(6,2)=CEP(2,6)
  5354.       CEP(6,3)=CEP(3,6)
  5355.       CEP(6,4)=CEP(4,6)
  5356.       CEP(6,5)=CEP(5,6)
  5357.       CEP(6,6)=C2 - GAMA1*SYZ1
  5358. C
  5359.       RETURN
  5360. C
  5361.       END
  5362. C *CDC* *DECK EMAT3
  5363. C *UNI* )FOR,IS  N.EMAT3, R.EMAT3
  5364. C
  5365.       SUBROUTINE EMAT3(TMP,PROP,PROPI,A1,B1,C1,D1,E1,F1,KKK)
  5366. C
  5367. C
  5368. C
  5369. C     THIS SUBROUTINE CALCULATES THE ELASTIC AND INVERSE ELASTIC
  5370. C     PROPERTIES FOR A SPECIFIED TEMPERATURE AND FORMS THE ELASTIC
  5371. C     CONSTITUTIVE MATRIX
  5372. C
  5373. C
  5374. C
  5375. C
  5376.       IMPLICIT REAL*8 (A-H,O-Z)
  5377. C
  5378.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  5379. C
  5380.       DIMENSION PROP(16,1),PROPI(1)
  5381. C
  5382. C
  5383. C
  5384. C
  5385. C        1. INTERPOLATE MATERIAL PROPERTY TABLES
  5386. C
  5387.       CALL MTITP3(PROP,TMP,PROPI)
  5388.       YM=PROPI(1)
  5389.       PR=PROPI(2)
  5390. C
  5391. C        2. CALCULATE ELASTIC CONSTANTS
  5392. C
  5393.       A1=YM/(1.0 + PR)
  5394.       C1=A1*0.5
  5395.       A1=A1/(1.0 - 2.0*PR)
  5396.       B1=A1*PR
  5397.       A1=A1 - B1
  5398.       D1=PR/(PR - 1.0)
  5399.       E1=1.0/YM
  5400.       F1=-PR*E1
  5401. C
  5402. C        3. FORM ELASTIC CONSTITUTIVE MATRIX
  5403. C
  5404.    30 IF(KKK.EQ.1) RETURN
  5405. C
  5406.       DO 40 I=1,6
  5407.       DO 40 J=1,6
  5408.    40 C(I,J)=0.0
  5409. C
  5410.       C(1,1)=A1
  5411.       C(1,2)=B1
  5412.       C(1,3)=B1
  5413.       C(2,1)=B1
  5414.       C(2,2)=A1
  5415.       C(2,3)=B1
  5416.       C(3,1)=B1
  5417.       C(3,2)=B1
  5418.       C(3,3)=A1
  5419.       C(4,4)=C1
  5420.       C(5,5)=C1
  5421.       C(6,6)=C1
  5422. C
  5423.       RETURN
  5424. C
  5425.       END
  5426. C *CDC* *DECK MTITP3
  5427. C *UNI* )FOR,IS  N.MTITP3, R.MTITP3
  5428. C
  5429.       SUBROUTINE MTITP3(PROP,TMP,PROPI)
  5430. C
  5431. C
  5432. C
  5433. C     THIS SUBROUTINE LINEARLY INTERPOLATES THE MATERIAL PROPERTY
  5434. C     TABLES AND OBTAINS THE FOLLOWING PROPERTIES AT THE
  5435. C     SPECIFIED TEMPERATURE
  5436. C
  5437. C        YOUNGS MODULUS
  5438. C        POISSONS RATIO
  5439. C        VIRGIN MATERIAL YIELD STRESS
  5440. C        HARDENING MODULUS
  5441. C        MEAN COEFFICIENT OF THERMAL EXPANSION
  5442. C
  5443. C
  5444. C
  5445.       IMPLICIT REAL*8 (A-H,O-Z)
  5446. C
  5447.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5448.      1              TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5449.      2              SUBDD,RNGL,RNGU,DTT,TOL7,
  5450.      3              KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5451.       COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
  5452. C
  5453.       DIMENSION PROP(16,1),PROPI(1)
  5454. C
  5455. C
  5456. C
  5457. C
  5458. C        1. ENTER TEMPERATURE TABLE AND DETERMINE
  5459. C           INTERPOLATION FACTOR
  5460. C
  5461.     5 IF(TMP.GE.RNGL) GO TO 10
  5462.       WRITE(6,3001)
  5463.       STOP
  5464. C
  5465.    10 L=0
  5466.       DO 20 K=2,NPTS
  5467.       L=L + 1
  5468.       DUM=PROP(K,1)
  5469.       IF(K.EQ.NPTS) DUM=RNGU
  5470.       IF(TMP.GT.DUM) GO TO 20
  5471.       GO TO 25
  5472.    20 CONTINUE
  5473.       WRITE(6,3001)
  5474.       STOP
  5475. C
  5476.    25 XRATIO=(TMP - PROP(L,1))/(PROP(L + 1,1) - PROP(L,1))
  5477. C
  5478. C     CORRECT XRATIO FOR THE CASE WHEN TMP LIES OUTSIDE TABLE
  5479. C     BUT WITHIN THE TOLERANCE RANGE **
  5480. C
  5481.       IF(XRATIO.GT.1.0) XRATIO=1.0
  5482.       IF(XRATIO.LT.0.0) XRATIO=0.0
  5483. C
  5484. C        2. INTERPOLATE MATERIAL PROPERTIES
  5485. C
  5486. C     PROPI(J) CONTAINS INTERPOLATED VALUES **
  5487. C
  5488. C        PROPI(1) = YOUNGS MODULUS
  5489. C        PROPI(2) = POISSONS RATIO
  5490. C        PROPI(3) = VIRGIN MATERIAL YIELD STRESS
  5491. C        PROPI(4) = HARDENING MODULUS
  5492. C        PROPI(5) = MEAN COEFFICIENT OF THERMAL EXPANSION
  5493. C
  5494.       DO 30 M=2,6
  5495.    30 PROPI(M - 1)=PROP(L,M) + XRATIO*(PROP(L + 1,M) - PROP(L,M))
  5496. C
  5497.       RETURN
  5498. C
  5499.  3001 FORMAT(//,92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PRO
  5500.      1PERTY TEMPERATURES  (SUBROUTINE MTITP3))
  5501. C
  5502.       END
  5503. C *CDC* *DECK CREEP3
  5504. C *UNI* )FOR.IS  N.CREEP3, R.CREEP3
  5505. C
  5506.       SUBROUTINE CREEP3(DDT,DEPSC,TEMPD,EPSC,ORIG,NORG,STRESS,GAMA,
  5507.      1                  STRNR,PTIME2,EST,SX,SY,SZ,SXY,SXZ,SYZ,F,R,G,
  5508.      2                  INDEX,ECSTR)
  5509. C
  5510. C
  5511. C
  5512. C     THIS SUBROUTINE CALCULATES THE CREEP STRAIN RATE USING TOTAL
  5513. C     CREEP STRAIN HARDENING AND THE ORNL AUXILIARY HARDENING RULES FOR
  5514. C     CYCLIC CREEP
  5515. C
  5516. C
  5517. C
  5518.       IMPLICIT REAL*8 (A-H,O-Z)
  5519. C
  5520.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  5521.      1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  5522.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  5523.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  5524.       COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
  5525.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5526.      1              TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5527.      2              SUBDD,RNGL,RNGU,DTT,TOL7,
  5528.      3              KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5529. C
  5530.       DIMENSION DEPSC(6),ORIG(6,1),EPSC(1),STRESS(1)
  5531. C
  5532. C
  5533. C
  5534.       IMAX=50
  5535.       ETOL1=5.0D-3
  5536.       ETOL4=5.0D-6
  5537.       ETOL5=1.0D-20
  5538. C
  5539. C        1. CALCULATE THE CURRENT VALUE OF EFFECTIVE CREEP STRAIN
  5540. C
  5541.    10 CALL CYCRP3(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
  5542.       IF(EST.LE.TOL5) RETURN
  5543. C
  5544.       IF(KCRP.EQ.2) GO TO 20
  5545. C
  5546. C        2. ANALYTICAL SOLUTION FOR CREEP LAW NO. 1
  5547. C
  5548.       CALL CRPLW3(EST,ECSTR,STRN,STRNR,DDT,TEMPD,F,R,G)
  5549.       GO TO 60
  5550. C
  5551. C        3. NUMERICAL SOLUTION FOR CREEP LAW NO. 2
  5552. C
  5553. C
  5554. C     USE NEWTON ITERATION TO SOLVE FOR CURRENT EFFECTIVE
  5555. C     CREEP STRAIN RATE **
  5556. C
  5557. C
  5558. C     MAKE INITIAL GUESS OF PSEUDO-TIME *
  5559. C
  5560.    20 PTIME1=DBLE(FLOAT(KSTEP))*DTT + TSTART
  5561.       PTIME2=PTIME1
  5562. C
  5563.       KOUNT=1
  5564.    25 CALL CRPLW3(EST,ECSTR,STRN,STRNR,PTIME2,TEMPD,F,R,G)
  5565. C
  5566.       IMOD=0
  5567.       FUNCT=STRN-ECSTR
  5568.       DELTA=FUNCT/STRNR
  5569.       IF(ECSTR.EQ.0.0) DELTA=PTIME2
  5570. C
  5571. C     MODIFY DELTA, IF NECESSARY, TO OBTAIN A VALUE
  5572. C     OF PSEUDO-TIME .GE. 0.0 **
  5573. C
  5574.       IF((PTIME2 - DELTA).GE.0.0) GO TO 30
  5575.       DELTA=0.5*PTIME2
  5576.       IMOD=1
  5577. C
  5578.    30 IF(KOUNT.GT.1) GO TO 40
  5579.       PTIME2=PTIME1 - DELTA
  5580.       DNORM1=DABS(DELTA)
  5581.       KOUNT=KOUNT + 1
  5582.       GO TO 25
  5583. C
  5584. C     APPLY CONVERGENCE CRITERIA FOR KOUNT .GT.1 **
  5585. C
  5586.    40 DNORM2=DABS(DELTA)
  5587.       IF(IMOD.EQ.1) GO TO 50
  5588.       IF(DNORM2.LE.DNORM1) GO TO 45
  5589. C
  5590. C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
  5591. C     TOLERANCE BAND **
  5592. C
  5593.       XTOL=ETOL4*PTIME1
  5594.       IF(PTIME1.LE.ETOL5) XTOL=ETOL5
  5595.       IF(DNORM2.LE.XTOL.AND.DNORM1.LE.XTOL) GO TO 60
  5596.       GO TO 50
  5597. C
  5598.    45 XTOL=ETOL1*PTIME1
  5599.       IF(PTIME1.LE.ETOL5) XTOL=ETOL5
  5600.       IF(DNORM1.LE.XTOL) GO TO 60
  5601. C
  5602. C     NO CONVERGENCE *
  5603. C
  5604.    50 KOUNT=KOUNT + 1
  5605.       IF(KOUNT.LE.IMAX) GO TO 55
  5606.       WRITE(6,2000)
  5607.       STOP
  5608. C
  5609.    55 PTIME1=PTIME2
  5610.       PTIME2=PTIME2 - DELTA
  5611.       DNORM1=DNORM2
  5612.       GO TO 25
  5613. C
  5614. C        4. CALCULATE INITIAL ESTIMATE OF INCREMENTAL CREEP STRAINS
  5615. C
  5616.    60 GAMA=1.5*STRNR/EST
  5617.       C1=GAMA*DDT
  5618. C
  5619.   100 DEPSC(1)=C1*SX
  5620.       DEPSC(2)=C1*SY
  5621.       DEPSC(3)=C1*SZ
  5622.       DEPSC(4)=C1*2.0*SXY
  5623.       DEPSC(5)=C1*2.0*SXZ
  5624.       DEPSC(6)=C1*2.0*SYZ
  5625. C
  5626.       RETURN
  5627. C
  5628.  2000 FORMAT(//,69H    ERROR   NEWTON ITERATION FAILED TO CONVERGE   (SU
  5629.      1BROUTINE CREEP3))
  5630. C
  5631.       END
  5632. C *CDC* *DECK CYCRP3
  5633. C *UNI* )FOR.IS  N.CYCRP3, R.CYCRP3
  5634. C
  5635.       SUBROUTINE CYCRP3(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
  5636. C
  5637. C
  5638. C
  5639. C     THIS SUBROUTINE PERFORMS THE ORNL-TM-3602 AUXILIARY STRAIN
  5640. C     HARDENING CALCULATIONS FOR CYCLIC CREEP
  5641. C
  5642. C     THE FOLLOWING VARIABLES ARE USED
  5643. C
  5644. C        ORIG(I,J)   =  ARRAY CONTAINING POSITIVE ORIGIN IN THE FIRST
  5645. C                       COLUMN AND NEGATIVE ORIGIN IN THE SECOND
  5646. C        EPSD        =  DISTANCE BETWEEN CURRENT ORIGINS
  5647. C        EPSC(I)     =  CURRENT CREEP STRAIN COMPONENTS
  5648. C        NORG        =  DENOTES CURRENT ORIGIN
  5649. C                    =  1 POSITIVE ORIGIN
  5650. C                    =  2 NEGATIVE ORIGIN
  5651. C        STRESS(I)   =  CURRENT STRESSES
  5652. C        ECSTR       =  EFFECTIVE STRAIN MEASURE OF THE DISTANCE BETWEEN
  5653. C                       THE CURRENT CREEP STRAIN STATE AND ORIGIN
  5654. C
  5655. C
  5656. C
  5657.       IMPLICIT REAL*8 (A-H,O-Z)
  5658. C
  5659.       DIMENSION STRESS(1),EPSC(1),ORIG(6,1)
  5660. C
  5661. C
  5662. C     STRESS REVERSAL CAN OCCUR ONLY AT THE START OF A
  5663. C     SUBDIVISION (INDEX = 1)
  5664. C
  5665.       IF(INDEX.GT.1) GO TO 50
  5666. C
  5667. C
  5668. C        1. CALCULATE CURRENT DISTANCE BETWEEN ORIGINS
  5669. C
  5670.       CALL EFCST3(EPSD,ORIG,ORIG,2)
  5671. C
  5672. C        2. CHECK FOR STRESS REVERSAL
  5673. C
  5674.       DUM=0.0
  5675.       DO 15 I=1,6
  5676.    15 DUM=DUM+(EPSC(I)-ORIG(I,NORG))*STRESS(I)
  5677.       IF(DUM.GE.0.0) GO TO 50
  5678. C
  5679. C     STRESS REVERSAL IS INDICATED **
  5680. C
  5681.       CALL EFCST3(ECSTR,EPSC,ORIG,NORG)
  5682. C
  5683. C     CHECK IF OPPOSITE ORIGIN COORDINATES MUST BE RESET TO
  5684. C     NEW VALUES **
  5685. C
  5686.       IF(ECSTR.GT.EPSD) GO TO 40
  5687. C
  5688. C     CHECK FOR FALSE STRESS REVERSAL *
  5689. C
  5690.       IF(NORG.EQ.2) GO TO 18
  5691.    17 NN=2
  5692.       GO TO 19
  5693.    18 NN=1
  5694.    19 DUM=0.0
  5695. C
  5696.       DO 20 I=1,6
  5697.    20 DUM=DUM+(EPSC(I)-ORIG(I,NN))*STRESS(I)
  5698.       IF(DUM.GE.0.0) GO TO 25
  5699. C
  5700. C     FALSE REVERSAL IS INDICATED
  5701. C
  5702.       CALL EFCST3(TECSTR,EPSC,ORIG,NN)
  5703.       IF(ECSTR.GE.TECSTR) RETURN
  5704. C
  5705. C        3. RESET ORIGIN INDICATOR ONLY
  5706. C
  5707.    25 IF(NORG.EQ.2) GO TO 35
  5708.    30 NORG=2
  5709.       GO TO 50
  5710.    35 NORG=1
  5711.       GO TO 50
  5712. C
  5713. C        4. RESET ORIGIN INDICATOR AND COORDINATES
  5714. C
  5715.    40 IF(NORG.EQ.2) GO TO 42
  5716.    41 NORG=2
  5717.       GO TO 45
  5718.    42 NORG=1
  5719. C
  5720.    45 DO 48 I=1,6
  5721.    48 ORIG(I,NORG)=EPSC(I)
  5722. C
  5723. C        5. CALCULATE NEW VALUE OF EFFECTIVE CREEP STRAIN
  5724. C
  5725.    50 CALL EFCST3(ECSTR,EPSC,ORIG,NORG)
  5726. C
  5727.       RETURN
  5728. C
  5729.       END
  5730. C *CDC* *DECK EFCST3
  5731. C *UNI* )FOR,IS  N.EFCST3, R.EFCST3
  5732. C
  5733.       SUBROUTINE EFCST3(ECSTR,EPSC,ORIG,NORG)
  5734. C
  5735. C
  5736. C
  5737. C     THIS SUBROUTINE CALCULATES THE EFFECTIVE CREEP STRAIN BASED ON THE
  5738. C     DISTANCE BETWEEN THE CURRENT CREEP STRAIN STATE AND THE
  5739. C     CURRENT ORIGIN
  5740. C
  5741. C
  5742. C
  5743.       IMPLICIT REAL*8 (A-H,O-Z)
  5744. C
  5745.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5746.      1              TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5747.      2              SUBDD,RNGL,RNGU,DTT,TOL7,
  5748.      3              KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5749. C
  5750.       DIMENSION DEPSC(6),EPSC(1),ORIG(6,1)
  5751. C
  5752. C
  5753. C
  5754.       DO 10 I=1,6
  5755.    10 DEPSC(I)=EPSC(I)-ORIG(I,NORG)
  5756. C
  5757.       ECSTR=DSQRT(XCON1*(DEPSC(1)*DEPSC(1) + DEPSC(2)*DEPSC(2) +
  5758.      1           DEPSC(3)*DEPSC(3)) + XCON2*(DEPSC(4)*DEPSC(4)
  5759.      2           +DEPSC(5)*DEPSC(5)+DEPSC(6)*DEPSC(6)))
  5760. C
  5761.       RETURN
  5762. C
  5763.       END
  5764. C *CDC* *DECK CRPLW3
  5765. C *UNI* )FOR,IS  N.CRPLW3, R.CRPLW3
  5766. C
  5767.       SUBROUTINE CRPLW3(STRESS,ECSTR,STRAIN,STRNR,TIME,TEMPD,F,R,G)
  5768. C
  5769. C
  5770. C
  5771. C     THIS SUBROUTINE CONTAINS THE UNIAXIAL CREEP LAWS FOR MATERIAL
  5772. C     MODELS 10 AND 11  (3-D)
  5773. C
  5774. C
  5775. C     THE FOLLOWING VARIABLES ARE USED FOR THE UNIAXIAL LAWS
  5776. C
  5777. C        STRESS = UNIAXIAL STRESS
  5778. C        STRAIN = UNIAXIAL CREEP STRAIN
  5779. C        STRNR = UNIAXIAL CREEP STRAIN RATE
  5780. C        TIME = TIME
  5781. C        TEMPD = TEMPERATURE
  5782. C        CRPCON = CONSTANTS FOR UNIAXIAL CREEP LAW
  5783. C        ECSTR = MODIFIED EFFECTIVE CREEP STRAIN (O.R.N.L. RULES)
  5784. C
  5785. C
  5786. C
  5787.       IMPLICIT REAL*8 (A-H,O-Z)
  5788. C
  5789.       COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
  5790.      1              TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
  5791.      2              SUBDD,RNGL,RNGU,DTT,TOL7,
  5792.      3              KCRP,NITE,NALG,IINTP,NPTS,ITCHK
  5793. C
  5794. C
  5795. C
  5796.       A0=CRPCON(1)
  5797.       A1=CRPCON(2)
  5798.       A2=CRPCON(3)
  5799.       A3=CRPCON(4)
  5800.       A4=CRPCON(5)
  5801.       A5=CRPCON(6)
  5802.       A6=CRPCON(7)
  5803. C
  5804.       IF(KCRP.EQ.2) GO TO 50
  5805. C
  5806. C        1. CREEP LAW NO. 1
  5807. C
  5808.       IF(A2.GE.1.0) GO TO 20
  5809. C
  5810.       RTTOL=20.
  5811.       EX1=1./(1.-A2)
  5812.       EX2=A1*EX1
  5813.       EX3=A2*EX1
  5814.       EX4=-RTTOL*EX3
  5815. C
  5816. C     CALCULATE MINIMUM ALLOWABLE EFFECTIVE CREEP STRAIN **
  5817. C
  5818.       ECMIN=(A0**EX1)*(STRESS**EX2)*(A2**EX3)*(10.0**EX4)
  5819.       IF(ECSTR.LE.ECMIN) GO TO 40
  5820. C
  5821.    20 EX5=1.0/A2
  5822.       EX6=A1*EX5
  5823.       EX7=(A2-1.)/A2
  5824.       IF(A2.EQ.1.0.AND.ECSTR.EQ.0.0) GO TO 25
  5825.       EX8=ECSTR**EX7
  5826.       GO TO 30
  5827.    25 EX8=1.0
  5828. C
  5829.    30 STRNR=(A0**EX5)*(STRESS**EX6)*A2*EX8
  5830. C
  5831.       RETURN
  5832. C
  5833.    40 STRAIN=A0*(STRESS**A1)*(TIME**A2)
  5834.       STRNR=STRAIN/TIME
  5835. C
  5836.       RETURN
  5837. C
  5838. C        2. CREEP LAW NO. 2
  5839. C
  5840.    50 F=A0*DEXP(A1*STRESS)
  5841.       R=A2*((STRESS/A3)**A4)
  5842.       G=A5*DEXP(A6*STRESS)
  5843.       STRAIN=F*(1.-DEXP(-R*TIME)) + (G*TIME)
  5844.       STRNR=F*R*DEXP(-R*TIME) + G
  5845. C
  5846.       RETURN
  5847. C
  5848.       END
  5849. C *CDC* *DECK OVL47
  5850. C *CDC*       OVERLAY (ADINA,4,7)
  5851. C *CDC* *DECK EL3D12
  5852. C *UNI* )FOR,IS  N.EL3D12, R.EL3D12
  5853. C *CDC*       PROGRAM EL3D12
  5854.       SUBROUTINE EL3D12
  5855. C
  5856.       IMPLICIT REAL*8 (A-H,O-Z)
  5857. C
  5858. C      M O D E L S = 12 - 16
  5859. C
  5860. C
  5861.       RETURN
  5862.       END
  5863. C *CDC* *DECK OVL50
  5864. C *CDC*       OVERLAY (ADINA,5,0)
  5865. C *CDC* *DECK BEAM
  5866. C *UNI* )FOR,IS N.BEAM,R.BEAM
  5867. C *CDC*       PROGRAM BEAM
  5868. C
  5869. C
  5870.       SUBROUTINE BEAM
  5871. C
  5872. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  5873. C .                                                                 .
  5874. C .   STORAGE                                                       .
  5875. C .                                                                 .
  5876. C .      N101  E        YOUNG'S  MODULUS                            .
  5877. C .      N102  G        SHEAR  MODULUS                              .
  5878. C .      N103  DEN      DENSITY                                     .
  5879. C .      N104  XI       SECOND MOMENT OF AREA ABOUT   R - AXIS      .
  5880. C .      N105  YI       SECOND MOMENT OF AREA ABOUT   S - AXIS      .
  5881. C .      N106  ZI       SECOND MOMENT OF AREA ABOUT   T - AXIS      .
  5882. C .      N107  AREA     NORMAL + SHEAR  SECTION  AREA               .
  5883. C .      N108  XYZ      ELEMENT  COORDINATE  ARRAY                  .
  5884. C .      N109  LM                                                   .
  5885. C .      N110  IPS      STRESS  OUTPUT  FLAG                        .
  5886. C .      N111  MATP                                                 .
  5887. C .      N112  PROP                                                 .
  5888. C .      N114  ISHEAR   FLAG  FOR  TRANSVERSE  SHEAR  EFFECTS       .
  5889. C .      N115  WA                                                   .
  5890. C .      N116  ITABLE   STRESS  OUTPUT  TABLES                      .
  5891. C .      N117  SR       GAUSS  ELIMINATION  COEFFICIENTS            .
  5892. C .      N124  ISKEW    NODAL SKEW COORDINATE SYSTEM                .
  5893. C .                                                                 .
  5894. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  5895. C
  5896.       IMPLICIT REAL*8 (A-H,O-Z)
  5897. C
  5898.       COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
  5899.       COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
  5900.       COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
  5901.       COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
  5902.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  5903.      1          ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
  5904.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  5905.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  5906.       COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
  5907.       COMMON /DPR/ ITWO
  5908.       COMMON /JUNK/ IHED(18),MTOT,LPROG
  5909.       COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
  5910.       COMMON /STNL/ XLT,XOL,YOL,ZOL,FAC,PFAC,INTX,INTY,INTZ,NST
  5911.       COMMON /SKEW/ NSKEWS
  5912.       COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
  5913.      1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
  5914.      2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
  5915. C
  5916.       COMMON A(1)
  5917.       REAL A
  5918.       DIMENSION IA(1)
  5919.       EQUIVALENCE (A(1),IA(1))
  5920. C
  5921.       EQUIVALENCE (NPAR(2),NUME),(NPAR(16),NUMMAT),(NPAR(17),NCON)
  5922.      1        ,(NPAR(15),MODEL),(NPAR(13),NTABLE),(NPAR(3),INDNL)
  5923.      2        ,(NPAR(4),IDEATH),(NPAR(14),JTABLE),(NPAR(12),NMOMNT)
  5924.       EQUIVALENCE (NPAR(5),ITYPB),(NPAR(6),NEGSKS),(NPAR(7),ISECT)
  5925.      1        ,(NPAR(1),NPAR1)
  5926. C
  5927. C
  5928.       DIMENSION WORD(2)
  5929.       DATA WORD /6HSTRESS , 6HFORCE  /
  5930.       INTX=NPAR(9)
  5931.       INTY=NPAR(10)
  5932.       INTZ=NPAR(11)
  5933. C
  5934. C
  5935.       IF (IND.GT.0) GO TO 275
  5936. C
  5937. C
  5938. C     I N P U T   P H A S E
  5939. C     C H E C K   T H E   N P A R   V E C T O R   F O R
  5940. C     R A N G E   A N D   C O M P A T I B I L I T Y
  5941. C
  5942. C
  5943. C
  5944. C     CHECK ON RANGE AND SET DEFAULTS FOR NPAR VECTOR
  5945. C
  5946. C
  5947.       ISTOP=0
  5948.       IF (NUME.GT.0) GO TO 10
  5949.       ISTOP=ISTOP + 1
  5950.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5951.       ISUB=2
  5952.       IRANGE=1
  5953.       WRITE (6,2400) ISTOP,ISUB,ISUB,IRANGE,ISUB,NPAR(ISUB)
  5954. C
  5955.    10 IF (INDNL.GE.0 .AND. INDNL.LT.3) GO TO 15
  5956.       ISTOP=ISTOP + 1
  5957.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5958.       ISUB=3
  5959.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  5960. C
  5961.    15 IF (IDEATH.GE.0 .AND. IDEATH.LT.3) GO TO 20
  5962.       ISTOP=ISTOP + 1
  5963.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5964.       ISUB=4
  5965.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  5966. C
  5967.    20 IF (INDNL.EQ.0) GO TO 70
  5968. C
  5969.       IF (ITYPB.GE.0 .AND. ITYPB.LT.2) GO TO 25
  5970.       ISTOP=ISTOP + 1
  5971.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5972.       ISUB=5
  5973.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  5974. C
  5975.    25 IF (NEGSKS.EQ.0) GO TO 27
  5976.       IF (NSKEWS.GT.0) GO TO 27
  5977.       ISUB=6
  5978.       ISTOP=ISTOP + 1
  5979.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5980.       WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
  5981. C
  5982.    27 IF (ISECT.EQ.0) ISECT=1
  5983.       IF (ISECT.GT.0 .AND. ISECT.LT.3) GO TO 30
  5984.       ISTOP=ISTOP + 1
  5985.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  5986.       ISUB=7
  5987.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  5988. C
  5989. C
  5990. C
  5991. C     THE PROGRAM REQUIRES INTY=7 AND INTZ=7 WHEN A NONLINEAR
  5992. C     ANALYSIS OF A RECTANGULAR BEAM IS CARRIED OUT (FOR 3-D ACTION )
  5993. C
  5994.    30 IF ( ISECT.EQ.2 .OR. ITYPB.EQ.0 .OR. INDNL.EQ.0 ) GO TO 31
  5995.       IF (INTY.NE.0 .AND. INTY.NE.7) WRITE (6,3301)
  5996.       IF (INTZ.NE.0 .AND. INTZ.NE.7) WRITE (6,3302)
  5997.       INTY=7
  5998.       INTZ=7
  5999. C
  6000.    31 IF (INTX.GT.2 .OR. INTY.NE.0 .OR. INTZ.NE.0 ) GO TO 36
  6001.       INTX=5
  6002.       IF (ISECT-1) 32,32,34
  6003.    32 INTY=3
  6004.       INTZ=1
  6005.       IF (ITYPB.GT.0) INTZ=3
  6006.       GO TO 60
  6007.    34 INTY=1
  6008.       INTZ=7+ITYPB
  6009.       GO TO 60
  6010. C
  6011.    36 IF (INTX.LT.3) INTX=3
  6012.       IF (INTY.NE.0) GO TO 38
  6013.       IF (ISECT-1) 40,40,42
  6014.    40 INTY=3
  6015.       INTZ=1
  6016.       IF (ITYPB.GT.0) INTZ=3
  6017.       GO TO 60
  6018.    42 INTY=1
  6019.       INTZ=7+ITYPB
  6020.       GO TO 60
  6021.    38 IF (INTZ.EQ.0) INTZ=3
  6022. C
  6023. C
  6024.       IF (INTX.LT.8) GO TO 44
  6025.       ISTOP=ISTOP + 1
  6026.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6027.       ISUB=9
  6028.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6029. C
  6030.    44 IF (INTY.LT.8) GO TO 46
  6031.       ISTOP=ISTOP + 1
  6032.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6033.       ISUB=10
  6034.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6035. C
  6036.    46 KK=8
  6037.       IF (ISECT.EQ.2) KK=8+ITYPB
  6038.       IF (INTZ.LT.KK) GO TO 48
  6039.       ISTOP=ISTOP + 1
  6040.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6041.       ISUB=11
  6042.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6043. C
  6044.    48 L=INTX - (INTX/2)*2
  6045.       IF (L.GT.0) GO TO 50
  6046.       INTX=INTX + 1
  6047.       WRITE (6,2010)
  6048.    50 L=INTY - (INTY/2)*2
  6049.       IF (L.GT.0) GO TO 52
  6050.       INTY=INTY + 1
  6051.       WRITE (6,2010)
  6052.    52 IF (ISECT.EQ.2) GO TO 60
  6053.       L=INTZ -(INTZ/2)*2
  6054.       IF (L.GT.0) GO TO 60
  6055.       INTZ=INTZ + 1
  6056.       WRITE (6,2010)
  6057. C
  6058. C
  6059.    60 NPAR(9)=INTX
  6060.       NPAR(10)=INTY
  6061.       NPAR(11)=INTZ
  6062. C
  6063.       IF (NMOMNT.GE.0) GO TO 65
  6064.       ISTOP=ISTOP + 1
  6065.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6066.       ISUB=12
  6067.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6068. C
  6069.    65 IF (NTABLE.GE.-1) GO TO 70
  6070.       ISTOP=ISTOP + 1
  6071.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6072.       ISUB=13
  6073.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6074. C
  6075.    70 IF (NTABLE.EQ. -1) JTABLE=12
  6076.       IF (JTABLE.EQ. 0) JTABLE=16
  6077. C
  6078.       IF (JTABLE.GT.0) GO TO 75
  6079.       ISTOP=ISTOP + 1
  6080.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6081.       ISUB=14
  6082.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6083. C
  6084.    75 IF (MODEL.EQ.0) MODEL=1
  6085.       IF (MODEL.GT.0) GO TO 80
  6086.       ISTOP=ISTOP + 1
  6087.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6088.       ISUB=15
  6089.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6090. C
  6091. C
  6092.    80 IF (NUMMAT.GE.0) GO TO 81
  6093.       ISTOP=ISTOP + 1
  6094.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6095.       ISUB=16
  6096.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6097. C
  6098.    81 IF (NUMMAT.EQ.0) NUMMAT=1
  6099. C
  6100.       NCONT=0
  6101.       IF (MODEL.EQ.2) GO TO 82
  6102.       IF (INDNL.GE.1 .AND. MODEL.EQ.1) NCONT=4
  6103.       NCON=NCONT
  6104.       GO TO 84
  6105. C
  6106.    82 NCONT=6
  6107.       IF (NCON.NE.0) GO TO 83
  6108.       NCON=NCONT
  6109.       GO TO 84
  6110. C
  6111.    83 IF (NCON.LE.6) GO TO 84
  6112.       ISTOP=ISTOP + 1
  6113.       ISUB=17
  6114.       WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
  6115. C
  6116. C
  6117. C
  6118. C     CHECK ON COMPATIBILITY BETWEEN ELEMENTS OF NPAR
  6119. C
  6120. C
  6121. C        1.     COMPATIBILITY OF INDNL AND IDEATH
  6122. C
  6123.    84 ISUB=3
  6124.       IF (INDNL.GT.0) GO TO 90
  6125.       IF (IDEATH.EQ.0) GO TO 85
  6126.       ISTOP=ISTOP + 1
  6127.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6128.       ISUD=4
  6129.       WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
  6130. C
  6131. C        2.     COMPATIBILITY OF INDNL AND MODEL
  6132. C
  6133.    85 IF (MODEL.EQ.1) GO TO 90
  6134.       ISTOP=ISTOP + 1
  6135.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6136.       ISUD=15
  6137.       WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
  6138. C
  6139. C        3.     COMPATIBILITY OF NEGSKS AND NSKEWS
  6140. C
  6141.    90 IF (NEGSKS.EQ.0) GO TO 95
  6142.       IF (NSKEWS.GT.0) GO TO 95
  6143.       ISUB=6
  6144.       ISTOP=ISTOP + 1
  6145.       IF (ISTOP.EQ.1) WRITE (6,2100) NG
  6146.       WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
  6147. C
  6148. C
  6149. C
  6150.    95 IF (ISTOP.GT.0) IDATWR=1
  6151.       IF (IDATWR.GT.1) GO TO 100
  6152. C
  6153. C     P R I N T   O U T   N P A R   V E C T O R
  6154. C
  6155.       WRITE (6,2099) NPAR1
  6156.       WRITE (6,2015) NUME,INDNL,IDEATH
  6157.       IF (INDNL.GT.0) GO TO 5
  6158.       WRITE (6,2012) NEGSKS,NMOMNT
  6159.       GO TO 4
  6160. C
  6161.     5 WRITE (6,2004) ITYPB,NEGSKS,ISECT
  6162.       IWORD=1
  6163.       IF (NTABLE.EQ. -1) IWORD=2
  6164.       WRITE (6,2014) INTX,INTY,INTZ,NMOMNT,NTABLE,WORD(IWORD),JTABLE
  6165.     4 WRITE (6,2001) MODEL,NUMMAT,NCON
  6166.       IF (INDNL.GT.1) WRITE (6,2698)
  6167. C
  6168.   100 IF (ISTOP.EQ.0) GO TO 275
  6169.       WRITE (6,2750)
  6170.       STOP
  6171. C
  6172. C
  6173.   275 NST=11
  6174.       IF (MODEL.EQ.1) NST=3
  6175.       IDWA=INTX*INTY*NPAR(11)*NST
  6176.       IF (INDNL.EQ.2) IDWA=IDWA + 1
  6177.       NMAT=0
  6178.       IF (INDNL.EQ.0) NMAT=NUMMAT
  6179.       INSR = 6 + 48*ITYPB
  6180. C
  6181.       NFIRST=N6
  6182.       IF(IND.EQ.4) NFIRST=N10
  6183.       N101=NFIRST + 20
  6184.       N102=N101 + NMAT*ITWO
  6185.       N103 = N102 + NMAT*ITWO
  6186.       N104 = N103 + NUMMAT*ITWO
  6187.       N105 = N104 + NMAT*ITWO
  6188.       N106 = N105 + NMAT*ITWO
  6189.       N107 = N106 + NMAT*ITWO
  6190.       N108 = N107 + 3*NMAT*ITWO
  6191.       N109 = N108 + 9*NUME*ITWO
  6192.       N110 = N109 + 12*NUME
  6193.       N111 = N110 + NUME
  6194.       N112 = N111 + NUME
  6195. C
  6196.       NFAC=1
  6197.       IF (NMAT.GT.0) NFAC=0
  6198.       N114 = N112 + NFAC*NCON*NUMMAT*ITWO
  6199.       N115 = N114 + NFAC*NUMMAT
  6200.       N116 = N115 + NFAC*IDWA*NUME*ITWO
  6201.       NTAB=NTABLE
  6202.       IF (NTABLE.LT.0) NTAB=0
  6203.       LL=JTABLE/16
  6204.       LLL=JTABLE - LL*16
  6205.       IF (LLL.GT.0) LL=LL + 1
  6206.       LL=LL*16
  6207.       N117 = N116 + LL*NFAC*NTAB
  6208.       N118 = N117 + INSR*NFAC*NUME*ITWO
  6209. C
  6210.       MM=0
  6211.       IF (IDEATH.GT.0) MM=1
  6212.       N119 = N118 + MM*NUME*ITWO
  6213.       MM=0
  6214.       IF (IDEATH.EQ.1) MM=1
  6215.       N120 = N119 + 12*MM*NUME*ITWO
  6216.       N121 = N120 + 6*NMOMNT
  6217.       N122 = N121 + NUME
  6218.       IF (NMOMNT.EQ.0) N122=N121
  6219.       N123 = N122 + 12*NUME*ITWO
  6220.       N124=N123 + NUME*ITWO
  6221.       IF (INDNL.EQ.0) N124=N122
  6222.       MM=0
  6223.       IF (NEGSKS.GT.0) MM=1
  6224.       N125=N124 + MM * (2*NUME)
  6225.       MM=1
  6226.       IF (NMOMNT.EQ.0) MM=0
  6227.       N126 = N125 + 36*MM*NFAC*NUME*ITWO
  6228.       MM=1
  6229.       IF (INDNL .EQ. 0) MM=0
  6230.       N127 = N126 + 8*MM*NUME*ITWO
  6231.       NLAST = N127 - 1
  6232. C
  6233. C
  6234.       IF (IND.NE.0) GO TO 105
  6235. C
  6236.       J=NFIRST - 1
  6237.       DO 102 I=1,20
  6238.       J=J+1
  6239.   102 IA(J)=NPAR(I)
  6240. C
  6241.       MIDEST=(NLAST-NFIRST) + 1
  6242.       WRITE (6,2000) NG,MIDEST
  6243.       CALL SIZE (NLAST)
  6244. C
  6245.   105 IF (IND.GT.3) GO TO 110
  6246.       M2=N2
  6247.       M3=N3
  6248.       M4=N4
  6249.       GO TO 120
  6250.   110 M2=N2
  6251.       M3=N7
  6252.       M4=N8
  6253.       IF (ICOUNT.LT.3) GO TO 120
  6254.       M2=N6
  6255. C
  6256.   120 CALL BMEL   (A(N06),A(N1A),
  6257.      1          A(N1),A(M2),A(M3),A(M4),A(N5),A(N101),A(N102),A(N103),
  6258.      1          A(N104),A(N105),A(N106),A(N107),A(N108),A(N109),
  6259.      2          A(N110),A(N111),A(N112),A(N114),A(N115),A(N116)
  6260.      3         ,A(N117),A(N118),A(N119),A(N120),A(N121),A(N122),A(N123),
  6261.      4          A(N124),A(N125),A(N126),
  6262.      5          NCON,NDOF,IDWA,NTAB,NMOMNT,INSR)
  6263. C
  6264.       RETURN
  6265. C
  6266. C
  6267. C
  6268.  2099 FORMAT(36H E L E M E N T   D E F I N I T I O N///,
  6269.      1       14H ELEMENT TYPE ,13(2H .),16H( NPAR(1) ). . =,I5/,
  6270.      2       25H     EQ.1, TRUSS ELEMENTS/,
  6271.      3       25H     EQ.2, 2-DIM ELEMENTS/,
  6272.      4       25H     EQ.3, 3-DIM ELEMENTS/,
  6273.      5        25H     EQ.4, BEAM  ELEMENTS/,
  6274.      6         28H     EQ.5, ISO/BEAM ELEMENTS/,
  6275.      6         28H     EQ.6, PLATE ELEMENTS   /,
  6276.      C        25H     EQ.7, SHELL ELEMENTS/,
  6277.      D        25H     EQ.8,9,10, EMPTY    /,
  6278.      G        32H     EQ.11, 2-DIM FLUID ELEMENTS/,
  6279.      5        32H     EQ.12, 3-DIM FLUID ELEMENTS   /)
  6280.  2015 FORMAT (20H NUMBER OF ELEMENTS.,10(2H .),16H( NPAR(2) ). . =,I5//,
  6281.      9       28H TYPE OF NONLINEAR ANALYSIS.,6(2H .),16H( NPAR(3) ). . =
  6282.      A,      I5/,
  6283.      "       40H     EQ.0, LINEAR ELASTIC ONLY                    /,
  6284.      B       38H     EQ.1, MATERIALLY NONLINEAR ONLY  /,
  6285.      C        45H     EQ.2, UPDATED LAGRANGIAN FORMULATION         //,
  6286.      D       32H ELEMENT BIRTH AND DEATH OPTIONS ,4(2H .),
  6287.      E       16H( NPAR(4) ). . =,I5/,
  6288.      F       40H     EQ.0, OPTION NOT ACTIVE                   /,
  6289.      G       40H     EQ.1, BIRTH OPTION ACTIVE                 /,
  6290.      H       40H     EQ.2, DEATH OPTION ACTIVE                  //)
  6291.  2001 FORMAT (42H M A T E R I A L   D E F I N I T I O N            ///,
  6292.      1        16H MATERIAL MODEL.,12(2H .),16H( NPAR(15)). . =,I5/,
  6293.      2        40H    EQ.1,   LINEAR ELASTIC                          /,
  6294.      3        40H    EQ.2,  ELASTIC-PLASTIC                         //,
  6295.      5        40H NUMBER OF DIFFERENT SETS OF MATERIAL               /,
  6296.      6        14H     CONSTANTS,13(2H .),16H( NPAR(16)). . =,I5//,
  6297.      7        40H NUMBER OF MATERIAL CONSTANTS PER SET. .  ,
  6298.      8        16H( NPAR(17)). . =,I5)
  6299.  2004 FORMAT (18H ELEMENT TYPE CODE,11(2H .),16H( NPAR(5) ). . =,I5/,
  6300.      1        40H     EQ.0, IN-PLANE BEAM                           /,
  6301.      2        45H     EQ.1, GENERAL 3-D BEAM                       //,
  6302.      2        23H SKEW COORDINATE SYSTEM  /
  6303.      3        24H     REFERENCE INDICATOR ,8(2H .),
  6304.      3        16H( NPAR(6) ). . =,I5/
  6305.      4        28H     EQ.0, ALL ELEMENT NODES  /
  6306.      5        37H           USE THE GLOBAL SYSTEM ONLY  /
  6307.      6        35H     EQ.1, ELEMENT NODES REFER       /
  6308.      7        36H           TO SKEW COORDINATE SYSTEM  //,
  6309.      X        28H SECTION IDENTIFICATION FLAG,6(2H .),
  6310.      Y        16H( NPAR(7) ). . =,I5/,
  6311.      Z        40H     EQ.1, RECTANGULAR SECTION                     /,
  6312.      *        40H     EQ.2, PIPE SECTION                          ///)
  6313.  2014 FORMAT (40H INTEGRATION ORDER IN   R   DIRECTION. .        ,
  6314.      1        16H( NPAR(9) ). . =,I5//,
  6315.      2        40H INTEGRATION ORDER IN   S   DIRECTION. .     ,
  6316.      3        16H( NPAR(10)). . =,I5//,
  6317.      2        40H INTEGRATION ORDER IN   T   DIRECTION. .     ,
  6318.      5        16H( NPAR(11)). . =,I5////,
  6319.      P        32H NUMBER OF MOMENT RELEASE TABLES  ,4(2H .),
  6320.      Q        16H( NPAR(12)). . =,I5///,
  6321.      6        40H NUMBER OF STRESS OUTPUT TABLES               ,
  6322.      7        16H( NPAR(13)). . =,I5/,
  6323.      8        30H    EQ.-1, PRINT NODAL FORCES     ,/,
  6324.      8        49H    EQ. 0, PRINT AT ALL INTEGRATION POINTS        ,//,
  6325.      9        15H MAXIMUM NO OF ,A6,18H OUTPUT LOCATIONS        ,/,
  6326.      A        14H    IN A TABLE,13(2H .),16H( NPAR(14)). . =,I5////)
  6327.  2012 FORMAT (23H SKEW COORDINATE SYSTEM  /
  6328.      3        24H     REFERENCE INDICATOR ,8(2H .),
  6329.      3        16H( NPAR(6) ). . =,I5/
  6330.      1        28H     EQ.0, ALL ELEMENT NODES  /
  6331.      2        37H           USE THE GLOBAL SYSTEM ONLY  /
  6332.      3        35H     EQ.1, ELEMENT NODES REFER       /
  6333.      3        36H           TO SKEW COORDINATE SYSTEM  //,
  6334.      4        32H NUMBER OF MOMENT RELEASE TABLES  ,4(2H .),
  6335.      1        16H( NPAR(12)). . =,I5///)
  6336.  2100 FORMAT (1H1,45HERROR IN ELEMENT GROUP CONTROL CARDS  (BEAM)  /
  6337.      1        16H ELEMENT GROUP =, I5/)
  6338.  2200 FORMAT (I5,7H. NPAR(,I2,27H) IS OUT OF RANGE ... NPAR(,I2,
  6339.      1        3H) =,I5)
  6340.  2400 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .GE., I2,10H ... NPAR(,I2,
  6341.      1        3H) =,I5)
  6342.  2500 FORMAT (I5,7H. NPAR(,I2,3H) =,I2,10H AND NPAR(,I2,3H) =,I2,
  6343.      1        19H ARE NOT COMPATIBLE )
  6344.  2550 FORMAT (I5,10H. NSKEWS =,I2,10H AND NPAR(,I2,3H) =,I2,
  6345.      1        19H ARE NOT COMPATIBLE )
  6346.  2750 FORMAT (//// 23H STOP  (ERROR IN NPAR)  )
  6347.  2010 FORMAT (//45H **WARNING** INCORRECT INTEGRATION ORDER        //)
  6348.  2000 FORMAT (///38H S T O R A G E   I N F O R M A T I O N,
  6349.      1        ///49H LENGTH OF ARRAY NEEDED FOR STORING ELEMENT GROUP/
  6350.      2        12H DATA (GROUP,I3,2H).,12(2H .),15H( MIDEST ). . =,I5)
  6351.  2698 FORMAT (////16H *** N O T E ***//
  6352.      1  52H IN GEOMETRIC NONLINEAR ANALYSIS, I.E., INDNL.GT.1, /
  6353.      2  52H THE TOTAL ROTATIONS AT THE NODAL POINTS PRINTED IN /
  6354.      3  52H THE STEP-BY-STEP SOLUTION ARE NOT USED.            //
  6355.      4  52H THE ELEMENT KINEMATICS AND STRESSES ARE CALCULATED /
  6356.      5  52H USING INCREMENTAL ROTATIONS.                       ///)
  6357.  3301 FORMAT (//15H *** NOTE ***      /
  6358.      1          45H INTEGRATION ORDER IN THE S-DIRECTION           /
  6359.      2          45H HAS BEEN RE-SET TO  7.                         /)
  6360.  3302 FORMAT (//15H *** NOTE ***      /
  6361.      1          45H INTEGRATION ORDER IN THE T-DIRECTION           /
  6362.      2          45H HAS BEEN RE-SET TO  7.                         /)
  6363. C
  6364.       END
  6365. C *CDC* *DECK BMEL
  6366. C *UNI* )FOR,IS N.BMEL,R.BMEL
  6367.       SUBROUTINE BMEL (RSDCOS,NODSYS,ID,X,Y,Z,HT,E,G,DEN,XI,YI,ZI,
  6368.      1                 AREA,XYZ,LM,IPS,MATP,PROP,ISHEAR,WA,ITABLE,
  6369.      2                 SR,ETIMV,EDISP,IMOMNT,IELRET,PDISP,GAMA,ISKEW,
  6370.      3                 SREL,RERIT,
  6371.      3                 NCON,NDOF,IDWA,NTAB,NMOMNT,INSR)
  6372. C
  6373. C
  6374. C     SUBROUTINE TO CALCULATE BEAM ELEMENT MATRICES AND
  6375. C     ELEMENT STRESSES
  6376. C
  6377. C
  6378. C
  6379.       IMPLICIT REAL*8 (A-H,O-Z)
  6380. C
  6381.       COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
  6382.       COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
  6383.      1      ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
  6384.       COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
  6385.       COMMON /EMBM/ S(78),XM(12),STR(78),D(3),AS(16,16),BS(3,3)
  6386.       COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
  6387.      1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
  6388.       COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
  6389.       COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
  6390.       COMMON /RANDI/ N0A,N1D,IELCPL
  6391.       COMMON /MDFRDM/ IDOF(6)
  6392.       COMMON /ELSTP/ TIME,IDTHF
  6393.       COMMON /STNL/ XLT,XOL,YOL,ZOL,FAC,PFAC,INTX,INTY,INTZ,NST
  6394.       COMMON /BTRANS/ DISP(16),DXYZ(9),XLN,EPS,EPS1
  6395.       COMMON /POS/ I1,I2,I3,ISTRES
  6396.       COMMON /PIE/ PI,TOPI,DEGRAD,RADEG
  6397.       COMMON /SKEW/ NSKEWS
  6398.       COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
  6399.      1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
  6400.      2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
  6401. C
  6402.       COMMON A(1)
  6403.       REAL A
  6404. C
  6405.       DIMENSION X(1),Y(1),Z(1),ID(NDOF,1),E(1),DEN(1),AREA(3,1),LM(12,1)
  6406.      1       ,XYZ(9,1),MATP(1),PROP(NCON,1),G(1),XI(1),YI(1),ZI(1)
  6407.       DIMENSION IPS(1),HT(1),ITABLE(NTAB,1),SR(INSR,1)
  6408.       DIMENSION T(3,3),WA(IDWA,1),ISHEAR(1),WORD(2),RE(16) ,
  6409.      1          ETIMV(1),EDISP(12,1),IMOMNT(6,NMOMNT),IELRET(1)
  6410.       DIMENSION PDISP(12,1),GAMA(1),ISKEW(2,1),RSDCOS(9,1),NODSYS(1)
  6411.      1          ,ILSK(4),ILTK(4),ILRK(4),SREL(36,1),RERIT(8,1)
  6412.       DIMENSION IPICK(7),XYZINT(3,392)
  6413. C
  6414.       EQUIVALENCE (NPAR(1),NPAR1),(NPAR(2),NUME),(NPAR(16),NUMMAT)
  6415.      1        ,(NPAR(15),MODEL),(NPAR(3),INDNL),(NPAR(4),IDEATH)
  6416.       EQUIVALENCE (NPAR(14),JTABLE),(NPAR(5),ITYPB),(NPAR(6),NEGSKS)
  6417.       EQUIVALENCE (NPAR(7),ISECT),(NPAR(13),NTABLE)
  6418. C
  6419. C
  6420. C    **NOTE**  DURING THE TIME INTEGRATION, X=DISP, Y=VEL, Z=ACC, HT=R
  6421. C
  6422. C     IF SKEW COORDINATE SYSTEMS ARE EMPLOYED IN THE U.L.
  6423. C     FORMULATION, EDISP AND PDISP TRANSLATIONS ARE
  6424. C     IN THE GLOBAL SYSTEM. HOWEVER, ONLY INCREMENTAL ROTATIONS
  6425. C     ARE ROTATED TO THE GLOBAL SYSTEM, I.E. EDISP AND
  6426. C     PDISP ROTATION COMPONENTS ARE IN THE SKEW SYSTEM.
  6427. C     GIVEN DISP, TRANSLATIONS ARE ROTATED IMMEDIATELY,
  6428. C     ROTATIONS ARE ROTATED ONLY AFTER THE INCREMENTS ARE FOUND.
  6429. C
  6430. C
  6431.       DATA IPICK /0,1,-1,2,-2,3,-3/
  6432.       DATA WORD/7HELASTIC,8H*PLASTIC/
  6433.       DATA RECLB1/8HTYPE-4  /, RECLB2/8HMATERAL4/, RECLB3/8HSECTION4/,
  6434.      1     RECLB4/8HOUTABLE4/, RECLB5/8HELEMENT4/, RECLB6/8HNEWSTEP4/,
  6435.      2     RECLB7/8HOUTPUT-4/, RECLB8/8HIPOINT-4/
  6436. C
  6437.       ND=12
  6438.       NPTS=JTABLE
  6439. C
  6440.       IELCPL=0
  6441.       IF (KPRI.EQ.0) GO TO 800
  6442.       IF (IND.GT.0) GO TO 420
  6443.       IJPORT=1
  6444.       IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) IJPORT=0
  6445. C
  6446. C***  DATA PORTHOLE (START)
  6447. C
  6448.       RECLAB=RECLB1
  6449.       IF (IJPORT.EQ.1)
  6450.      1 WRITE (LU1) RECLAB,NG,(NPAR(I),I=1,20),NSUB
  6451. C
  6452. C***  DATA PORTHOLE (END)
  6453. C
  6454. C
  6455. C     R E A D  A N D  G E N E R A T E  E L E M E N T
  6456. C     I N F O R M A T I O N
  6457. C
  6458. C
  6459.       IBUG=0
  6460.       IF (INDNL) 1,1,2
  6461. C
  6462. C     MATERIAL DATA
  6463. C
  6464.     1 IF (IDATWR.LE.1) WRITE (6,2002)
  6465.       DO 10 I=1,NUMMAT
  6466.       READ(5,1000) N,E(N),XNU,DEN(N)
  6467.       G(N)=E(N)/(2.*(1. + XNU))
  6468.       READ(5,1001) XI(N),YI(N),ZI(N),AREA(1,N),AREA(2,N),AREA(3,N)
  6469.    10 CONTINUE
  6470.       IF (IDATWR.GT.1) GO TO 30
  6471.       DO 9 N=1,NUMMAT
  6472.       XNU=E(N)/(2.*G(N))-1.0
  6473.     9 WRITE (6,2003) N,E(N),XNU,DEN(N)
  6474.       WRITE (6,2010)
  6475.       DO 11 N=1,NUMMAT
  6476.       WRITE(6,2009) N,XI(N),YI(N),ZI(N),AREA(1,N),AREA(2,N),AREA(3,N)
  6477.    11 CONTINUE
  6478.       GO TO 30
  6479. C
  6480.     2 IF (IDATWR.LE.1) WRITE (6,2020)
  6481.       DO 14 I=1,NUMMAT
  6482.       READ (5,1010) N,ISHEAR(N),DEN(N)
  6483.       IF (ISHEAR(N).LE.1) GO TO 22
  6484.       IBUG=1
  6485.       WRITE (6,3000) N,ISHEAR(N)
  6486.    22 READ (5,1011) (PROP(J,N),J=1,NCON)
  6487.       IF (ISECT.NE.2 .OR. PROP(4,N).LT.PROP(3,N)) GO TO 14
  6488.       IBUG=1
  6489.       WRITE (6,3401) NG,N
  6490.    14 CONTINUE
  6491.       DO 15 I=1,NUMMAT
  6492.    15 IF (IDATWR.LE.1) WRITE (6,2021) I,ISHEAR(I),DEN(I)
  6493. C
  6494.       IF (MODEL.EQ.2) GO TO 16
  6495.       IF (IDATWR.GT.1) GO TO 30
  6496.       WRITE (6,2030)
  6497.       DO 12 N=1,NUMMAT
  6498.    12 WRITE (6,2023) N,(PROP(I,N),I=1,NCON)
  6499.       GO TO 30
  6500. C
  6501.    16 IF (NCON.GT.6) GO TO 18
  6502.       IF (IDATWR.LE.1) WRITE (6,2022)
  6503.       DO 17 N=1,NUMMAT
  6504.       IF (PROP(5,N).GT.0.0) GO TO 41
  6505.       IBUG=1
  6506.       WRITE (6,3402) NG,N
  6507.    41 IF (PROP(6,N).LT.PROP(1,N)) GO TO 42
  6508.       IBUG=1
  6509.       WRITE (6,3403) NG,N
  6510.    42 IF (IDATWR.LE.1) WRITE (6,2023) N,(PROP(I,N),I=1,NCON)
  6511.    17 CONTINUE
  6512.       GO TO 30
  6513. C
  6514.    18 WRITE (6,2100)
  6515.       DO 19 N=1,NUMMAT
  6516.       WRITE (6,2110) N,(PROP(I,N),I=1,6)
  6517.       DO 13 J=8,NCON,2
  6518.       ET=(PROP(J-1,N) - PROP(J-3,N))/(PROP(J,N) - PROP(J-2,N))
  6519.    13 WRITE (6,2120) PROP(J-1,N),PROP(J,N),ET
  6520.    19 CONTINUE
  6521.    30 IF (MODEX.EQ.0 .OR. IBUG.EQ.0) GO TO 31
  6522.       WRITE (6,3404)
  6523.       STOP
  6524. C
  6525. C     ELEMENT END RELEASE TABLES
  6526. C
  6527.    31 IF (NMOMNT.EQ.0) GO TO 20
  6528.       IF (IDATWR.LE.1) WRITE (6,2210)
  6529.       DO 32 I=1,NMOMNT
  6530.       READ (5,1050) (IMOMNT(J,I),J=1,6)
  6531.    32 IF (IDATWR.LE.1) WRITE (6,2220) I,(IMOMNT(J,I),J=1,6)
  6532. C
  6533. C     READ TABLES FOR ELEMENT STRESS OUTPUT LOCATION
  6534. C
  6535.    20 IF (NTABLE.LE.0) GO TO 40
  6536.       L=JTABLE/16
  6537.       LL=JTABLE - 16*L
  6538.       IF (LL.GT.0) L=L + 1
  6539.       DO 25 I=1,NTABLE
  6540.       IF (IDATWR.LE.1) WRITE (6,2200) I
  6541.       K=0
  6542.       DO 24 J=1,L
  6543.       K=K + 1
  6544.       KK=K + 15
  6545.       READ (5,1009)(ITABLE(I,JJ),JJ=K,KK)
  6546.       IF (IDATWR.LE.1) WRITE (6,2201) (ITABLE(I,JJ),JJ=K,KK)
  6547.       DO 23 JJ=K,KK
  6548.       IF (ITABLE(I,JJ).EQ.0) GO TO 25
  6549.    23 CONTINUE
  6550.    24 K=KK
  6551.    25 CONTINUE
  6552.    40 IF (IDATWR.LE.1) WRITE (6,2011)
  6553. C
  6554. C***  DATA PORTHOLE (START)
  6555. C
  6556.       IF (IJPORT.EQ.0) GO TO 90
  6557.       IF (INDNL.GT.0) GO TO 70
  6558.       RECLAB=RECLB2
  6559.       DO 50 N=1,NUMMAT
  6560.       XNU=E(N)/(2.*G(N))-1.
  6561.    50 WRITE (LU1) RECLAB,E(N),XNU,DEN(N)
  6562.       RECLAB=RECLB3
  6563.       WRITE (LU1)  RECLAB,NUMMAT,(XI(I),YI(I),ZI(I),AREA(1,I),
  6564.      2             AREA(2,I),AREA(3,I),I=1,NUMMAT)
  6565.       GO TO 80
  6566. C
  6567.    70 RECLAB=RECLB2
  6568.       WRITE (LU1)  RECLAB,NUMMAT,NCON,(DEN(I),I=1,NUMMAT),
  6569.      1             ((PROP(I,J),I=1,NCON),J=1,NUMMAT)
  6570.       RECLAB=RECLB3
  6571.       WRITE (LU1)  RECLAB,NUMMAT,(ISHEAR(I),I=1,NUMMAT)
  6572. C
  6573.    80 RECLAB=RECLB4
  6574.       IF (NTABLE.LE.0)
  6575.      1 WRITE (LU1)  RECLAB,NTABLE
  6576.       IF(NTABLE.GT.0)
  6577.      1 WRITE(LU1) RECLAB,NTABLE,((ITABLE(I,J),I=1,NTAB),J=1,NPTS)
  6578. C
  6579. C***  DATA PORTHOLE (END)
  6580. C
  6581.    90 N=1
  6582.       IREAD=5
  6583.       IF (INPORT.GT.0) IREAD=59
  6584.       ISCONT=0
  6585.       IF (NEGSKS.EQ.0 .AND. NSKEWS.GT.0) ISCONT=1
  6586.   100 READ (IREAD,1002) M,II,JJ,KK,MTYP,IS,KG,ETIME,IELRE,INTLOC
  6587.       IF (N.EQ.1 .AND. M.NE.1) GO TO 115
  6588.       IF (KG.EQ.0) KG=1
  6589.       IF (IDEATH.EQ.2 .AND. ETIME.EQ.0.D0) ETIME=1.D8
  6590.   120 IF (M.NE.N) GO TO 200
  6591.       K=KK
  6592.       I=II
  6593.       J=JJ
  6594.       MTYPE=MTYP
  6595.       KKK=KG
  6596.       IPST= IS
  6597.       ETIM=ETIME
  6598.       IELREM=IELRE
  6599.       INTLM=INTLOC
  6600. C
  6601. C     SAVE ELEMENT INFORMATION
  6602. C
  6603.   200 XYZ(1,N)=X(I)
  6604.       XYZ(2,N)=Y(I)
  6605.       XYZ(3,N)=Z(I)
  6606. C
  6607.       XYZ(4,N)=X(J)
  6608.       XYZ(5,N)=Y(J)
  6609.       XYZ(6,N)=Z(J)
  6610. C
  6611.       XYZ(7,N)=X(K)
  6612.       XYZ(8,N)=Y(K)
  6613.       XYZ(9,N)=Z(K)
  6614. C
  6615.       IF (ISCONT.EQ.0) GO TO 203
  6616.       IF (NODSYS(I).EQ.0 .AND. NODSYS(J).EQ.0) GO TO 205
  6617.       WRITE (6,2410) NG,N,NEGSKS
  6618.       STOP
  6619.   115 WRITE (6,3500) NSUB,NG
  6620.       STOP
  6621.   203 IF (NEGSKS.EQ.0) GO TO 205
  6622.       ISKEW(1,N)=NODSYS(I)
  6623.       ISKEW(2,N)=NODSYS(J)
  6624.       IF (NODSYS(I).EQ.0 .AND. NODSYS(J).EQ.0) ISKEW(1,N)=-1
  6625.   205 CONTINUE
  6626. C
  6627.       MATP(N)=MTYPE
  6628.       IPS(N) = IPST
  6629.       IF (NMOMNT.GT.0) IELRET(N)=IELREM
  6630. C
  6631. C
  6632.       IF (IDEATH.EQ.0) GO TO 210
  6633.       IF (IDEATH.EQ.2) GO TO 206
  6634.       DO 208 L=1,12
  6635.   208 EDISP(L,N)=0.
  6636.       ETIMV(N)=-ETIM
  6637.       GO TO 210
  6638.   206 ETIMV(N)=ETIM
  6639. C
  6640.   210 LL=1
  6641.       DO 211 L=1,6
  6642.       LM(L,N)=0
  6643.       LM(L+6,N)=0
  6644.       IF (IDOF(L) .EQ. 1) GO TO 211
  6645.       LM(L,N)=ID(LL,I)
  6646.       LM(L+6,N)=ID(LL,J)
  6647.       LL=LL+1
  6648.   211 CONTINUE
  6649. C
  6650. C     UPDATE COLUMN HEIGHTS AND BANDWIDTH
  6651. C
  6652.       CALL COLHT (HT,ND,LM(1,N))
  6653. C
  6654.       IF (IDATWR.LE.1)
  6655.      1  WRITE (6,2005) N,I,J,K,MTYPE,IPST,KKK,ETIM,IELREM,INTLM
  6656.       IF (IJPORT.EQ.0 .AND. INTLM.EQ.0) GO TO 249
  6657. C
  6658. C     CALCULATE GLOBAL COORDINATES OF INTEGRATION POINTS
  6659. C     NOT APPLICABLE FOR LINEAR ELEMENTS
  6660. C
  6661.       IF (INDNL.LE.0) GO TO 229
  6662.       NPT=INTX*INTY*INTZ
  6663.       TOL=1.D-8
  6664. C
  6665. C     CALCULATE UNIT VECTORS IN THE R,S AND T DIRECTIONS
  6666. C
  6667.       RX=X(J) - X(I)
  6668.       RY=Y(J) - Y(I)
  6669.       RZ=Z(J) - Z(I)
  6670.       DUM=DSQRT(RX*RX + RY*RY + RZ*RZ)
  6671.       IF (DUM.GT.TOL) GO TO 219
  6672.       WRITE (6,3010) NG,N
  6673.       STOP
  6674.   219 RX=RX/DUM
  6675.       RY=RY/DUM
  6676.       RZ=RZ/DUM
  6677.       AX=X(K) - X(I)
  6678.       AY=Y(K) - Y(I)
  6679.       AZ=Z(K) - Z(I)
  6680.       TX=RY*AZ - RZ*AY
  6681.       TY=RZ*AX - RX*AZ
  6682.       TZ=RX*AY - RY*AX
  6683.       DUM=DSQRT(TX*TX + TY*TY + TZ*TZ)
  6684.       IF (DUM.GT.TOL) GO TO 221
  6685.       WRITE (6,3011) NG,N
  6686.       STOP
  6687.   221 TX=TX/DUM
  6688.       TY=TY/DUM
  6689.       TZ=TZ/DUM
  6690.       SX=TY*RZ - TZ*RY
  6691.       SY=TZ*RX - TX*RZ
  6692.       SZ=TX*RY - TY*RX
  6693. C
  6694.       CALL LENGTH (XLT,XYZ(1,N))
  6695. C
  6696.       IX=INTX-1
  6697.       IF (IX.EQ.0) IX=1
  6698.       IY=INTY-1
  6699.       IF (IY.EQ.0) IY=1
  6700.       IZ=INTZ-1
  6701.       IF (IZ.EQ.0) IZ=1
  6702.       IF (INTZ.EQ.8) IZ=8
  6703.       XINT=0.5*(X(I) + X(J))
  6704.       YINT=0.5*(Y(I) + Y(J))
  6705.       ZINT=0.5*(Z(I) + Z(J))
  6706.       DSECT1=PROP(3,MTYPE)
  6707.       DSECT2=PROP(4,MTYPE)
  6708.       DRINT=XLT/DBLE(FLOAT(IX))
  6709.       IF (ISECT.EQ.2) GO TO 213
  6710. C
  6711. C     RECTANGULAR SECTION GEOMETRY
  6712. C
  6713.       DSINT=DSECT1/DBLE(FLOAT(IY))
  6714.       DTINT=DSECT2/DBLE(FLOAT(IZ))
  6715.       GO TO 214
  6716. C
  6717. C     PIPE SECTION GEOMETRY
  6718. C
  6719.   213 RMEAN=0.5*(DSECT1 + DSECT2)
  6720.       DRAD=0.5*(DSECT1 - DSECT2)
  6721.       DANG=4.*DATAN(1.D0)/DBLE(FLOAT(IZ))
  6722.       IF (INTZ.EQ.8) DANG=DANG*2.
  6723. C
  6724. C     CALCULATE LOCATION  OF INTEGRATION POINTS
  6725. C
  6726.   214 KINTP=0
  6727.       DO 228 I1=1,INTX
  6728.       RINTP=IPICK(I1)*DRINT
  6729.       IF (ISECT.EQ.2) GO TO 222
  6730. C
  6731. C     BEAM WITH RECTANGULAR SECTION
  6732. C
  6733.       DO 220 I2=1,INTY
  6734.       SINTP=IPICK(I2)*DSINT
  6735.       DO 220 I3=1,INTZ
  6736.       TINTP=IPICK(I3)*DTINT
  6737.       KINTP=KINTP+1
  6738.       XYZINT(1,KINTP)=XINT + RX*RINTP + SX*SINTP + TX*TINTP
  6739.       XYZINT(2,KINTP)=YINT + RY*RINTP + SY*SINTP + TY*TINTP
  6740.       XYZINT(3,KINTP)=ZINT + RZ*RINTP + SZ*SINTP + TZ*TINTP
  6741. C
  6742. C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
  6743. C
  6744.       IF (IDATWR.GT.1 .OR. INTLM.LE.0) GO TO 220
  6745.       WRITE (6,2310) I1,I2,I3,(XYZINT(L,KINTP),L=1,3)
  6746.   220 CONTINUE
  6747.       GO TO 228
  6748. C
  6749. C     BEAM WITH PIPE SECTION
  6750. C
  6751.   222 DO 226 I2=1,INTY
  6752.       SINT=RMEAN + IPICK(I2)*DRAD
  6753.       DO 226 I3=1,INTZ
  6754.       TINT=(I3-1)*DANG
  6755.       SINTP=SINT*DCOS(TINT)
  6756.       TINTP=SINT*DSIN(TINT)
  6757.       KINTP=KINTP+1
  6758.       XYZINT(1,KINTP)=XINT + RX*RINTP + SX*SINTP + TX*TINTP
  6759.       XYZINT(2,KINTP)=YINT + RY*RINTP + SY*SINTP + TY*TINTP
  6760.       XYZINT(3,KINTP)=ZINT + RZ*RINTP + SZ*SINTP + TZ*TINTP
  6761. C
  6762. C     PRINT INTEGRATION POINT LOCATIONS IF  INTLM.GT.0
  6763. C
  6764.       IF (IDATWR.GT.1 .OR. INTLM.LE.0) GO TO 226
  6765.       WRITE (6,2310) I1,I2,I3,(XYZINT(L,KINTP),L=1,3)
  6766.   226 CONTINUE
  6767.   228 CONTINUE
  6768.       GO TO 230
  6769.   229 IF (INTLM.GT.0) WRITE (6,3013)
  6770. C
  6771. C***  DATA PORTHOLE (START)
  6772. C
  6773.   230 IF (IJPORT.EQ.0) GO TO 249
  6774.       RECLAB=RECLB5
  6775.       WRITE (LU1) RECLAB,N,I,J,K,MTYPE,IPST,ETIM,IELREM,INTLM
  6776.       RECLAB = RECLB8
  6777.       IF (INDNL.GT.0)
  6778.      1  WRITE (LU1) RECLAB,NPT,((XYZINT(L,I),L=1,3),I=1,NPT)
  6779.   249 CONTINUE
  6780. C
  6781. C***  DATA PORTHOLE (END)
  6782. C
  6783.       IF (N.EQ.NUME) GO TO 250
  6784.       N=N+1
  6785.       I=I+KKK
  6786.       J=J+KKK
  6787.       IF (N.GT.M) GO TO 100
  6788.       GO TO 120
  6789.   250 IF (INDNL.EQ.0) GO TO 262
  6790. C
  6791. C     INITIALIZE WORKING ARRAYS
  6792. C
  6793.       DO 252 N=1,NUME
  6794. C
  6795.       GAMA(N)=0.
  6796.       DO 216 L=1,ND
  6797.   216 PDISP(L,N)=0.
  6798. C
  6799.       MTYPE=MATP(N)
  6800. C
  6801. C     SR ARRAY CONTAINS THE GAUSS ELIMINATION COEFFICIENTS.
  6802. C
  6803. C     JNSR ARE THE NUMBER OF ENTRIES IN THE SR MATRIX.
  6804. C
  6805.       IF ( ( ISHEAR(MTYPE) + ITYPB ).EQ. 0) GO TO 253
  6806.       JNSR = 6 + ( 19*ITYPB + 29*ISHEAR(MTYPE) )*ITYPB
  6807.       DO 254 L=1,JNSR
  6808.   254 SR(L,N)=0.
  6809.       DO 218 I=1,8
  6810.   218 RERIT(I,N)=0.0
  6811.   253 DO 255 I=1,IDWA
  6812.   255 WA(I,N)=0.
  6813.       IF (MODEL.EQ.1)GO TO 252
  6814.       IST=1 - NST
  6815.       IF (INDNL.EQ.2) IST=IST + 1
  6816.       MTYPE=MATP(N)
  6817.       DO 260 I1=1,INTX
  6818.       DO 260 I3=1,INTZ
  6819.       DO 260 I2=1,INTY
  6820.       IST=IST + NST
  6821.   260 WA(IST,N)=-PROP(5,MTYPE)
  6822.   252 CONTINUE
  6823.       IF (NMOMNT.EQ.0) GO TO 262
  6824.       DO 245 N=1,NUME
  6825.       DO 245 I=1,36
  6826.   245 SREL(I,N)=0.
  6827.   262 IF (NEGSKS.EQ.0) GO TO 275
  6828.       DO 265 N=1,NUME
  6829.       IF (ISKEW(1,N).GE.0) GO TO 270
  6830.   265 CONTINUE
  6831.       WRITE (6,2400) NG,NEGSKS
  6832.   270 CONTINUE
  6833. C
  6834.   275 RETURN
  6835. C
  6836. C
  6837.   420 GO TO (440,560,560,700) ,IND
  6838. C
  6839. C
  6840. 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
  6841. C
  6842. C
  6843.   440 ITONLY=0
  6844.       DO 500 N=1,NUME
  6845. C
  6846.       CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
  6847.       IF (ICODE.EQ.1) GO TO 500
  6848. C
  6849.       MTYPE = MATP(N)
  6850.       CALL LENGTH (XLT,XYZ(1,N))
  6851.       CALL STIFF (AS,XLT,E(MTYPE),G(MTYPE),XI(MTYPE),YI(MTYPE),
  6852.      1            ZI(MTYPE),AREA(1,MTYPE))
  6853. C
  6854.       IF (NMOMNT.EQ.0) GO TO 445
  6855.       IELRE=IELRET(N)
  6856.       IF (IELRE.EQ.0) GO TO 445
  6857.       CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
  6858.   445 CONTINUE
  6859. C
  6860.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  6861.       K= 0
  6862.       DO 530 I= 1,12
  6863.       DO 530 J=I,12
  6864.       K= K+1
  6865.   530 S(K)= AS(I,J)
  6866. C
  6867.       IF (NEGSKS.EQ.0) GO TO 520
  6868.       IF (ISKEW(1,N).LT.0) GO TO 520
  6869.       ILSK(1)=ISKEW(1,N)
  6870.       ILSK(2)=ILSK(1)
  6871.       ILSK(3)=ISKEW(2,N)
  6872.       ILSK(4)=ILSK(3)
  6873.       CALL ATKA (RSDCOS,S,ILSK,4,3)
  6874.   520 CONTINUE
  6875. C
  6876.       CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  6877.   500 CONTINUE
  6878.       RETURN
  6879. C
  6880. C
  6881. C     A S S E M B L E  M A S S  M A T R I X
  6882. C
  6883. C
  6884.   560 GO TO (545,550),IMASS
  6885. C
  6886. C     LUMPED  MASS  DISCRETIZATION
  6887. C
  6888.   545 DO 546 N=1,NUME
  6889.       MTYPE=MATP(N)
  6890.       CALL LENGTH (XLT,XYZ(1,N))
  6891.       IF (INDNL.NE.0) GO TO 547
  6892.       XAREA=AREA(1,MTYPE)
  6893.       GO TO 548
  6894.   547 XAREA=PROP(3,MTYPE)*PROP(4,MTYPE)
  6895.       IF (ISECT.LE.1) GO TO 548
  6896.       XAREA=PI*(PROP(3,MTYPE)**2 - PROP(4,MTYPE)**2)/4.
  6897. C
  6898.   548 XMM=XLT*XAREA*DEN(MTYPE)/2.
  6899.       DO 549 L=1,3
  6900.       XM(L)= XMM
  6901.       XM(L+3)=0.
  6902.       XM(L+6)=XMM
  6903.   549 XM(L+9)=0.
  6904.       CALL ADDMA (A(N4),XM,LM(1,N),ND)
  6905.   546 CONTINUE
  6906.       RETURN
  6907. C
  6908. C     CONSISTENT MASS DISCRETIZATION
  6909. C
  6910.   550 ITONLY=0
  6911.       DO 670 N=1,NUME
  6912.       CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
  6913.       IF (ICODE.EQ.1) GO TO 670
  6914.       MTYPE=MATP(N)
  6915.       CALL LENGTH (XLT,XYZ(1,N))
  6916.       IF (INDNL.NE.0) GO TO 562
  6917.       XAREA=AREA(1,MTYPE)
  6918.       YYI=YI(MTYPE)
  6919.       ZZI=ZI(MTYPE)
  6920.       XXI=YYI + ZZI
  6921.       GO TO 569
  6922. C
  6923.   562 IF (ISECT-1) 561,561,565
  6924. C
  6925. C     RECTANGULAR  CROSS-SECTION
  6926. C
  6927.   561 XAREA=PROP(3,MTYPE)*PROP(4,MTYPE)
  6928.       ZZI=(XAREA*PROP(3,MTYPE)**2)/12.
  6929.       YYI=(XAREA*PROP(4,MTYPE)**2)/12.
  6930.       XXI=YYI + ZZI
  6931.       GO TO 569
  6932. C
  6933. C     PIPE CROSS-SECTION
  6934. C
  6935.   565 XAREA=PI*(PROP(3,MTYPE)**2 - PROP(4,MTYPE)**2)/4.
  6936.       YYI=XAREA*(PROP(3,MTYPE)**2 + PROP(4,MTYPE)**2)/16.
  6937.       ZZI=YYI
  6938.       XXI=YYI + ZZI
  6939. C
  6940.   569 CALL MASS (AS,XLT,XXI,YYI,ZZI,XAREA,DEN(MTYPE))
  6941. C
  6942.       IF (NMOMNT.EQ.0) GO TO 567
  6943.       IELRE=IELRET(N)
  6944.       IF (IELRE.EQ.0) GO TO 567
  6945.       CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
  6946.   567 CONTINUE
  6947. C
  6948.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  6949. C
  6950.       K= 0
  6951.       DO 675 I= 1,12
  6952.       DO 675 J= I,12
  6953.       K= K+1
  6954.   675 S(K) = AS(I,J)
  6955. C
  6956.       IF (NEGSKS.EQ.0) GO TO 680
  6957.       IF (ISKEW(1,N).LT.0) GO TO 680
  6958.       ILSK(1)=ISKEW(1,N)
  6959.       ILSK(2)=ILSK(1)
  6960.       ILSK(3)=ISKEW(2,N)
  6961.       ILSK(4)=ILSK(3)
  6962.       CALL ATKA (RSDCOS,S,ILSK,4,3)
  6963.   680 CONTINUE
  6964. C
  6965.       CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  6966. C
  6967.   670 CONTINUE
  6968.       RETURN
  6969. C
  6970. C
  6971. C     A S S E M B L E    F I N A L   N O N L I N E A R
  6972. C     S T I F F N E S S    M A T R I X
  6973. C
  6974. C
  6975.   700 ISTRES=-1
  6976.       DO 710 N=1,NUME
  6977. C
  6978.       CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
  6979.       IF (ICODE .EQ. 1) IELCPL=IELCPL + 1
  6980.       IF (ICODE.EQ.1) GO TO 710
  6981. C
  6982.       ISKEL=0
  6983.       IF (NEGSKS.EQ.0) GO TO 685
  6984.       IF (ISKEW(1,N).LT.0) GO TO 685
  6985.       ISKEL=1
  6986.       ILSK(1)=ISKEW(1,N)
  6987.       ILSK(2)=ILSK(1)
  6988.       ILSK(3)=ISKEW(2,N)
  6989.       ILSK(4)=ILSK(3)
  6990.       ILTK(1)=ISKEW(1,N)
  6991.       ILTK(2)=0
  6992.       ILTK(3)=ISKEW(2,N)
  6993.       ILTK(4)=0
  6994.       ILRK(1)=0
  6995.       ILRK(2)=ISKEW(1,N)
  6996.       ILRK(3)=0
  6997.       ILRK(4)=ISKEW(2,N)
  6998.   685 CONTINUE
  6999. C
  7000.       IF (IDEATH.EQ.0) GO TO 692
  7001.       ETIM=DABS(ETIMV(N))
  7002.       IF (IDEATH.EQ.2) GO TO 690
  7003.       IF (TIME.LT.ETIM) GO TO 710
  7004.       IF (ETIMV(N).GE.0.D0) GO TO 692
  7005.       ETIMV(N)=ETIM
  7006.       DO 695 L=1,12
  7007.       I=LM(L,N)
  7008.       IF (I.EQ.0) GO TO 695
  7009.       IF (I.LT.0) I=NEQ - I
  7010.       EDISP(L,N)=X(I)
  7011.   695 CONTINUE
  7012.       IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,EDISP(1,N),ILTK,4,3,1)
  7013.       GO TO 692
  7014.   690 IF (TIME.GT.ETIM) GO TO 710
  7015. C
  7016.   692 MTYPE=MATP(N)
  7017.       EY=PROP(1,MTYPE)
  7018.       XNU=PROP(2,MTYPE)
  7019.       FAC=EY/(1. - XNU - 2.*XNU*XNU)
  7020.       PFAC=EY/(2.*(1. + XNU))
  7021. C
  7022.       DO 735 I=1,16
  7023.       DISP(I)=0.0
  7024.   735 RE(I)=0.0
  7025. C
  7026.   718 DO 720 I=1,ND
  7027.       IP=LM(I,N)
  7028.       IF (IP.EQ.0) GO TO 720
  7029.       IF (IP.LT.0) IP=NEQ - IP
  7030.       DISP(I)=X(IP)
  7031.   720 CONTINUE
  7032. C
  7033. C     ROTATE TRANSLATIONS TO GLOBAL SYSTEM
  7034. C
  7035.       IF (ISKEL.EQ.0) GO TO 770
  7036.       CALL DIRCOS (RSDCOS,DISP,ILTK,4,3,1)
  7037.   770 CONTINUE
  7038. C
  7039.       MTYPE=MATP(N)
  7040. C
  7041. C
  7042.       IF (IDEATH.NE.1) GO TO 728
  7043.       DO 772 I=1,ND
  7044.   772 DISP(I)=DISP(I) - EDISP(I,N)
  7045.       DO 727 L=1,3
  7046.       DXYZ(L)=XYZ(L,N) + EDISP(L,N)
  7047.   727 DXYZ(L+3)=XYZ(L+3,N) + EDISP(L+6,N)
  7048.       CALL LENGTH(XLT,DXYZ)
  7049.       GO TO 730
  7050.   728 CALL LENGTH (XLT,XYZ(1,N))
  7051.   730 ITONLY=1
  7052.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  7053. C
  7054. C     CALCULATE NEW LOCAL AXIS FOR U.L. FORMULATION
  7055. C
  7056.   712 ITONLY=3
  7057.       IF (INDNL.EQ.2)
  7058.      1 CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  7059.       DO 762 I=1,12
  7060.       DISP(I)=DISP(I) - PDISP(I,N)
  7061.       IF (ICOUNT.NE.3 .AND. ITONLY.NE.5)
  7062.      1 PDISP(I,N)=PDISP(I,N) + DISP(I)
  7063.   762 CONTINUE
  7064. C
  7065. C     ROTATE INCREMENTAL ROTATIONS TO GLOBAL SYSTEM
  7066. C
  7067.       IF (ISKEL.EQ.0) GO TO 780
  7068.       CALL DIRCOS (RSDCOS,DISP,ILRK,4,3,1)
  7069.   780 CONTINUE
  7070.       IF (INDNL.LT.2) XLN=XLT
  7071. C
  7072. C     TRANSER THE GLOBAL DISPLACEMENT TO THE LOCAL COORDINATE
  7073. C
  7074.       DO 722 I=1,10,3
  7075.       DO 722 J=1,3
  7076.       IJ=I + J - 1
  7077.       TEMP=0.
  7078.       DO 723 K=1,3
  7079.       IK=I + K - 1
  7080.   723 TEMP=TEMP + T(J,K)*DISP(IK)
  7081.   722 XM(IJ)=TEMP
  7082.       DO 725 I=1,12
  7083.   725 DISP(I)=XM(I)
  7084.       IF (NMOMNT.EQ.0) GO TO 755
  7085.       IELRE=IELRET(N)
  7086.       IF (IELRE.EQ.0) GO TO 755
  7087.       NDRL=0
  7088.       DO 756 I=1,6
  7089.       IF (IMOMNT(I,IELRE).EQ.0) GO TO 757
  7090.   756 NDRL=NDRL + 1
  7091.   757 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,3)
  7092.   755 CONTINUE
  7093. C
  7094.       CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
  7095.      1            ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
  7096. C
  7097.       DO 732 I=1,ND
  7098.   732 XM(I)=RE(I)
  7099.       DO 733 I=1,10,3
  7100.       DO 733 J=1,3
  7101.       TEMP=0.0
  7102.       IJ=I + J - 1
  7103.       DO 734 K=1,3
  7104.       IK=I + K - 1
  7105.   734 TEMP=TEMP + T(K,J)*XM(IK)
  7106.   733 RE(IJ)=TEMP
  7107.   714 MADR=N3
  7108.       IF (ICOUNT.EQ.3) MADR=N5
  7109.       IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,RE,ILSK,4,3,2)
  7110.       CALL ADDBAN (A(MADR),A(N1),S,RE,LM(1,N),ND,2)
  7111. C
  7112.       IF (ICOUNT-2) 740,740,710
  7113.   740 IF (IREF) 710,742,710
  7114.   742 K=0
  7115. C
  7116.       IF (NMOMNT.EQ.0) GO TO 750
  7117.       IELRE=IELRET(N)
  7118.       IF (IELRE.EQ.0) GO TO 750
  7119.       NDRL=0
  7120.       DO 751 I=1,6
  7121.       IF (IMOMNT(I,IELRE).EQ.0) GO TO 752
  7122.   751 NDRL=NDRL + 1
  7123.   752 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,2)
  7124.   750 CONTINUE
  7125. C
  7126.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),2)
  7127.       DO 745 I=1,ND
  7128.       DO 745 J=I,ND
  7129.       K=K + 1
  7130.   745 S(K)=AS(I,J)
  7131.       IF (ISKEL.EQ.1) CALL ATKA (RSDCOS,S,ILSK,4,3)
  7132.       CALL ADDBAN (A(N4),A(N1),S,RE,LM(1,N),ND,1)
  7133.   710 CONTINUE
  7134.       IF (IELCPL.EQ.NUME) IELCPL=-1
  7135.       RETURN
  7136. C
  7137. C     S T R E S S  C A L C U L A T I O N S
  7138. C
  7139. C
  7140. C
  7141. C***  DATA PORTHOLE (START)
  7142. C
  7143.   800 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 802
  7144.       RECLAB=RECLB6
  7145.       WRITE (LU1) RECLAB,NG,(NPAR(I),I=1,20),KSTEP,TIME,NEGL,NSUB
  7146. C
  7147. C***  DATA PORTHOLE (END)
  7148. C
  7149.   802 IF (INDNL.GT.0) GO TO 850
  7150. C
  7151. C     GEOMETRICALLY AND  MATERIALLY LINEAR STRESS CALCULATION
  7152. C
  7153.       IPRNT = 0
  7154.       ITONLY=1
  7155.       DO 830 N= 1,NUME
  7156.       IPST= IPS(N)
  7157.       IF (IPST.EQ.0) GO TO 830
  7158.       DO 806 I=1,12
  7159.   806 STR(I)=0.
  7160.       IF (IPRI.NE.0) GO TO 810
  7161.       IPRNT=IPRNT + 1
  7162.       IF (IPRNT.NE.1) GO TO 810
  7163.       WRITE(6,2006) NG
  7164.   810 MTYPE=MATP(N)
  7165.       CALL LENGTH (XLT,XYZ(1,N))
  7166.       CALL STIFF (AS,XLT,E(MTYPE),G(MTYPE),XI(MTYPE),YI(MTYPE),
  7167.      1            ZI(MTYPE),AREA(1,MTYPE))
  7168. C
  7169.       IF (NMOMNT.EQ.0) GO TO 815
  7170.       IELRE=IELRET(N)
  7171.       IF (IELRE.EQ.0) GO TO 815
  7172.       CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,1,1)
  7173. C
  7174.   815 CONTINUE
  7175. C
  7176.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  7177.       DO 820 I=1,ND
  7178.       DISP(I)=0.
  7179.       IP=LM(I,N)
  7180.       IF (IP.EQ.0) GO TO 820
  7181.       IF (IP.LT.0) IP=NEQ - IP
  7182.       DISP(I)=X(IP)
  7183.   820 CONTINUE
  7184.       IF (NEGSKS.EQ.0) GO TO 822
  7185.       IF (ISKEW(1,N).LT.0) GO TO 822
  7186.       ILSK(1)=ISKEW(1,N)
  7187.       ILSK(2)=ILSK(1)
  7188.       ILSK(3)=ISKEW(2,N)
  7189.       ILSK(4)=ILSK(3)
  7190.       CALL DIRCOS (RSDCOS,DISP,ILSK,4,3,1)
  7191.   822 CONTINUE
  7192. C
  7193.       DO 840 I=1,10,3
  7194.       DO 840 J=1,3
  7195.       IJ=I+J-1
  7196.       TEMP=0.
  7197.       DO 835 K=1,3
  7198.       IK=I+K-1
  7199.   835 TEMP=TEMP + T(J,K)*DISP(IK)
  7200.   840 XM(IJ)=TEMP
  7201. C
  7202.       DO 824 I=1,12
  7203.       TEMP=0.
  7204.       DO 826 J=1,12
  7205.   826 TEMP=TEMP + AS(I,J)*XM(J)
  7206.   824 STR(I)=TEMP
  7207.       IF (IPRI.NE.0) GO TO 825
  7208.       WRITE(6,2007) N,(STR(I) ,I=1,6)
  7209.       WRITE(6,2008)  (STR(J) ,J=7,12)
  7210. C
  7211. C***  DATA PORTHOLE (START)
  7212. C
  7213.   825 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 830
  7214.       RECLAB=RECLB7
  7215.       WRITE(LU1) RECLAB,N,(STR(I),I=1,12)
  7216. C
  7217. C***  DATA PORTHOLE (END)
  7218. C
  7219.   830 CONTINUE
  7220.       RETURN
  7221. C
  7222. C
  7223. C     GEOMETRICALLY  OR/AND  MATERIALLY  NONLINEAR  STRESS  CALCULATION
  7224. C
  7225.   850 IPRNT=0
  7226.       DO 855 N=1,NUME
  7227. C
  7228.       ISKEL=0
  7229.       IF (NEGSKS.EQ.0) GO TO 876
  7230.       IF (ISKEW(1,N).LT.0) GO TO 876
  7231.       ISKEL=1
  7232.       ILTK(1)=ISKEW(1,N)
  7233.       ILTK(2)=0
  7234.       ILTK(3)=ISKEW(2,N)
  7235.       ILTK(4)=0
  7236.       ILRK(1)=0
  7237.       ILRK(2)=ISKEW(1,N)
  7238.       ILRK(3)=0
  7239.       ILRK(4)=ISKEW(2,N)
  7240.   876 CONTINUE
  7241. C
  7242.       IF (IDEATH.EQ.0) GO TO 854
  7243.       ETIM=DABS(ETIMV(N))
  7244.       IF (IDEATH.EQ.2) GO TO 853
  7245.       IF (TIME.LT.ETIM) GO TO 855
  7246.       GO TO 854
  7247.   853 IF (TIME.GT.ETIM) GO TO 855
  7248. C
  7249.   854 IPST=IPS(N)
  7250.       IF (IPST.EQ.0) GO TO 855
  7251.       IPRNT=IPRNT + 1
  7252.       IF (IPRNT.NE.1 .OR.  IPRI.NE.0) GO TO 894
  7253.       IF (NTABLE.EQ.-1) WRITE (6,2006) NG
  7254.       IF (NTABLE.GE.0) WRITE (6,2025) NG
  7255.   894 MTYPE = MATP(N)
  7256.       EY=PROP(1,MTYPE)
  7257.       XNU=PROP(2,MTYPE)
  7258.       FAC=EY/(1. - XNU -2.*XNU*XNU)
  7259.       PFAC=EY/(2.*(1. + XNU))
  7260.       DO 845 I=13,16
  7261.   845 DISP(I)=0.0
  7262.       DO 856 I=1,ND
  7263.       DISP(I)=0.
  7264.       IP=LM(I,N)
  7265.       IF (IP.EQ.0) GO TO 856
  7266.       IF (IP.LT.0) IP=NEQ - IP
  7267.       DISP(I)=X(IP)
  7268.   856 CONTINUE
  7269.       IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,DISP,ILTK,4,3,1)
  7270.       IF (IDEATH.NE.1) GO TO 880
  7271.       DO 886 I=1,ND
  7272.   886 DISP(I)=DISP(I) - EDISP(I,N)
  7273.       DO 858 L=1,3
  7274.       DXYZ(L)=XYZ(L,N) + EDISP(L,N)
  7275.   858 DXYZ(L+3)=XYZ(L+3,N) + EDISP(L+6,N)
  7276.       CALL LENGTH (XLT,DXYZ)
  7277.       GO TO 881
  7278.   880 CALL LENGTH (XLT,XYZ(1,N))
  7279.   881 CONTINUE
  7280. C
  7281. C     TRANSFER  THE  GLOBAL  DISPLACEMENTS  TO  LOCAL  COORDINATES
  7282. C
  7283.       ITONLY=1
  7284.       CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  7285. C
  7286. C     CALCULATE NEW LOCAL AXIS FOR U.L. FORMULATION
  7287. C
  7288.       ITONLY=3
  7289.       IF (INDNL.EQ.2)
  7290.      1 CALL TRANSF (XYZ(1,N),AS,BS,T,PDISP(1,N),GAMA(N),ITONLY)
  7291.       DO 863 I=1,ND
  7292.   863 DISP(I)=DISP(I) - PDISP(I,N)
  7293.       IF (ISKEL.EQ.1) CALL DIRCOS (RSDCOS,DISP,ILRK,4,3,1)
  7294.       IF (INDNL.LT.2) XLN=XLT
  7295. C
  7296.       DO 870 I=1,10,3
  7297.       DO 870 J=1,3
  7298.       IJ=I + J - 1
  7299.       TEMP=0.
  7300.       DO 871 K=1,3
  7301.       IK=I + K - 1
  7302.   871 TEMP=TEMP + T(J,K)*DISP(IK)
  7303.   870 XM(IJ)=TEMP
  7304.       DO 873 I=1,12
  7305.   873 DISP(I)=XM(I)
  7306.       IF (NMOMNT.EQ.0) GO TO 890
  7307.       IELRE=IELRET(N)
  7308.       IF (IELRE.EQ.0) GO TO 890
  7309.       NDRL=0
  7310.       DO 878 I=1,6
  7311.       IF (IMOMNT(I,IELRE).EQ.0) GO TO 879
  7312.   878 NDRL=NDRL + 1
  7313.   879 CALL ENDREL (AS,IMOMNT(1,IELRE),SREL(1,N),DISP,NDRL,3)
  7314. C
  7315. C
  7316.   890 ISTRES=0
  7317.       IF (NTABLE) 859,862,865
  7318. C
  7319. C     NTABLE.EQ.-1       NODAL FORCE CALCULATION
  7320. C     NTABLE.EQ. 0       STRESS CALCULATION AT ALL INTEGRATION POINTS
  7321. C
  7322.   859 DO 895 IJ=1,16
  7323.   895 RE(IJ) = 0.0
  7324.   862 CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
  7325.      1             ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
  7326.       IF (NTABLE.EQ.0) GO TO 891
  7327.       IF (IPRI.NE.0) GO TO 892
  7328.       WRITE (6,2007) N, ( RE(IN),IN=1,6 )
  7329.       WRITE (6,2008)     ( RE(IN),IN=7,12 )
  7330. C
  7331. C***  DATA PORTHOLE (START)
  7332. C
  7333.   892 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 893
  7334.       RECLAB=RECLB7
  7335.       WRITE(LU1) RECLAB,N,(RE(IN),IN=1,12)
  7336. C
  7337. C***  DATA PORTHOLE (END)
  7338. C
  7339.   893 CONTINUE
  7340.       GO TO 855
  7341. C
  7342.   891 IST = 1- NST
  7343.       IF (INDNL.EQ.2) IST=IST + 1
  7344.       LNC=0
  7345.       DO 860 I1=1,INTX
  7346.       DO 860 I3=1,INTZ
  7347.       DO 860 I2=1,INTY
  7348.       LNC=LNC+1
  7349.       IST=IST + NST
  7350.       J=1
  7351.       IF (MODEL.EQ.2) GO TO 910
  7352. C
  7353.       L1=IST
  7354.       L2=IST + 2
  7355.       IF (IPRI.NE.0) GO TO 920
  7356. C
  7357.       IF (LNC.LE.1) WRITE (6,2026) N
  7358.       WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
  7359.       GO TO 920
  7360. C
  7361.   910 IST1=IST + 1
  7362.       IST2=IST1 + 1
  7363.       IST3=IST2 + 3
  7364.       IST4=IST3 + 3
  7365.       L1=IST2
  7366.       L2=IST2 + 2
  7367.       L3=IST3
  7368.       L4=IST3 + 2
  7369.       L5=IST4
  7370.       L6=IST4 + 2
  7371.       IF (WA(IST,N).GT.0.0) J=2
  7372.       IF (IPRI.NE.0) GO TO 920
  7373. C
  7374.       IF (LNC.LE.1) WRITE (6,2026) N
  7375.       WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
  7376.       IF (IPST.LT.0) WRITE (6,2028) (WA(LK,N),LK=L3,L4)
  7377.       IF (IPST.LT.0) WRITE (6,2029) (WA(LK,N),LK=L5,L6)
  7378.       YLDOUT=DABS(WA(IST,N))
  7379.       WRITE (6,2031) YLDOUT,WA(IST1,N)
  7380. C
  7381. C***  DATA PORTHOLE (START)
  7382. C
  7383.   920 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 860
  7384.       RECLAB=RECLB7
  7385.       WRITE (LU1) RECLAB,N,I1,I2,I3,(WA(LK,N),LK=L1,L2)
  7386. C
  7387. C***  DATA PORTHOLE (END)
  7388. C
  7389.   860 CONTINUE
  7390. C
  7391.       IF (INDNL.EQ.2) WA(1,N)=EPS
  7392.       GO TO 855
  7393. C
  7394. C     STRESS CALCULATION AT SELECTED INTEGRATION POINTS
  7395. C
  7396.   865 ISTRES=1
  7397.       LNC=0
  7398.       L=IABS(IPST)
  7399.       IF (L.GT.NTABLE) L=NTABLE
  7400.       DO 867 K=1,JTABLE
  7401.       M=ITABLE(L,K)
  7402.       IF (M) 855,855,868
  7403.   868 I1=M/100
  7404.       II=M - I1*100
  7405.       I2=II/10
  7406.       I3=II - I2*10
  7407.       LNC=LNC+1
  7408.       IST=NST*(I2 - 1 + INTY*((I3 - 1) + INTZ*(I1 - 1))) + 1
  7409.       IF (INDNL.EQ.2) IST=IST + 1
  7410.       ISTRES=IST
  7411.       CALL STIFNL (DISP,PROP(1,MTYPE),WA(1,N),AS,RE,ISECT
  7412.      1             ,ISHEAR(MTYPE),SR(1,N),RERIT(1,N))
  7413.       J=1
  7414.       IF (MODEL.EQ.2) GO TO 930
  7415. C
  7416.       L1=IST
  7417.       L2=IST + 2
  7418.       IF (IPRI.NE.0) GO TO 940
  7419. C
  7420.       IF (LNC.LE.1) WRITE (6,2026) N
  7421.       WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
  7422.       GO TO 940
  7423. C
  7424.   930 IST1=IST + 1
  7425.       IST2=IST1 + 1
  7426.       IST3=IST2 + 3
  7427.       IST4=IST3 + 3
  7428.       L1=IST2
  7429.       L2=IST2 + 2
  7430.       L3=IST3
  7431.       L4=IST3 + 2
  7432.       L5=IST4
  7433.       L6=IST4 + 2
  7434.       IF (WA(IST,N).GT.0.0) J=2
  7435.       IF (IPRI.NE.0) GO TO 940
  7436. C
  7437.       IF (LNC.LE.1) WRITE (6,2026) N
  7438.       WRITE (6,2027) I1,I2,I3,WORD(J),(WA(LK,N),LK=L1,L2)
  7439.       IF (IPST.LT.0) WRITE (6,2028) (WA(LK,N),LK=L3,L4)
  7440.       IF (IPST.LT.0) WRITE (6,2029) (WA(LK,N),LK=L5,L6)
  7441.       YLDOUT=DABS(WA(IST,N))
  7442.       WRITE (6,2031) YLDOUT,WA(IST1,N)
  7443. C
  7444. C***  DATA PORTHOLE (START)
  7445. C
  7446.   940 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 867
  7447.       RECLAB=RECLB7
  7448.       WRITE (LU1) RECLAB,N,I1,I2,I3,(WA(LK,N),LK=L1,L2)
  7449. C
  7450. C***  DATA PORTHOLE (END)
  7451. C
  7452.   867 CONTINUE
  7453.       IF (INDNL.EQ.2) WA(1,N)=EPS
  7454. C
  7455.   855 CONTINUE
  7456.       RETURN
  7457. C
  7458.  1000 FORMAT (I5,3F10.0)
  7459.  1001 FORMAT (6F10.0)
  7460.  1002 FORMAT (7I5,F10.0,2I5)
  7461.  1009 FORMAT (16I5)
  7462.  1010 FORMAT (2I5,F10.0)
  7463.  1011 FORMAT (8F10.0)
  7464.  1050 FORMAT (6I5)
  7465. C
  7466. C
  7467.  2002 FORMAT (//,40H S E C T I O N   D E F I N I T I O N          //,
  7468.      1            2X,4HTYPE,11X,1HE,10X,3HXNU,12X,3HDEN)
  7469.  2003 FORMAT (/I5,5X,3E15.7)
  7470.  2005 FORMAT (/7I6,E10.3,2I6)
  7471.  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
  7472.      1 L E M E N T   G R O U P  ,I5,10H  (BEAMS) //,4X,
  7473.      2        7HELEMENT,7X,7HR-FORCE,8X,7HS-FORCE,8X,7HT-FORCE,
  7474.      3        12X,8HR-MOMENT,7X,8HS-MOMENT,7X,8HT-MOMENT/)
  7475.  2007 FORMAT (4X,I5,3X,1HI,2X,3E15.6,5X,3E15.6)
  7476.  2008 FORMAT (12X,1HJ,2X,3E15.6,5X,3E15.6/)
  7477.  2009 FORMAT(/,I5,5X,3E15.7,5X,3E15.7)
  7478.  2010 FORMAT (////,2X,4HTYPE,8X,9HR-INERTIA,6X,9HS-INERTIA,6X,
  7479.      1        9HT-INERTIA,15X,
  7480.      2        4HAREA,5X,13HSHEAR AREA(S),3X,13HSHEAR AREA(T))
  7481.  2011 FORMAT ( //,40H E L E M E N T   I N F O R M A T I O N         ///,
  7482.      1          43H     N     II    JJ    KK  TYPE   IPS    KG,4X,
  7483.      2          5HETIME,2X,5HIELRE,1X,6HINTLOC,3X,17HINTEGRATION POINT,
  7484.      3        13X,19HGLOBAL  COORDINATES/68X,17H  R      S      T, 1X,
  7485.      3          9X,1HX,12X,1HY,12X,1HZ)
  7486.  2310 FORMAT (69X,I2,2(5X,I2),4X,E11.4,2(2X,E11.4))
  7487.  3010 FORMAT (////14H *** STOP ***   //
  7488.      1  16H ELEMENT GROUP =,I5/
  7489.      2  36H ERROR IN NODE NUMBERING FOR ELEMENT,I5//)
  7490.  3011 FORMAT (////14H *** STOP ***   //
  7491.      1  16H ELEMENT GROUP =,I5/
  7492.      2  46H ERROR IN AUXILIARY NODE NUMBERING FOR ELEMENT, I5//)
  7493.  3013 FORMAT (69X,42H INTEGRATION POINT PRINTING NOT APPLICABLE)
  7494.  2020 FORMAT (///,40H S E C T I O N   D E F I N I T I O N         ///,
  7495.      1        5X,4HTYPE,5X,6HISHEAR,10X,3HDEN/)
  7496.  2021 FORMAT (4X,I5,5X,I5,3X,E15.4)
  7497.  2022 FORMAT (//,40H S E C T I O N   P R O P E R T Y              //,
  7498.      1       2X,4HTYPE,6X,9HPROP(1)=E,4X,11HPROP(2)=XNU,5X,10HPROP(3)=DO
  7499.      2,      5X,10HPROP(4)=DI,3X,12HPROP(5)=SIGY,5X,10HPROP(6)=ET/)
  7500.  2023 FORMAT (I5,6E15.4)
  7501.  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
  7502.      1 L E M E N T   G R O U P  ,I5,10H  (BEAMS) //,
  7503.      2        1X,7HELEMENT,2X,8HLOCATION,2X,6HSTRESS,6X,
  7504.      3        13HSTRESS/STRAIN,8X,2HRR,14X,2HRS,14X,2HRT,/,11X,
  7505.      4        7HR  S  T,2X,5HSTATE,7X,10HCOMPONENTS)
  7506.  2026 FORMAT (/,1X,I5)
  7507.  2027 FORMAT (10X,3(I2,1X),1X,A8,4X,6HSTRESS,9X,3(E14.6,2X))
  7508.  2028 FORMAT (32X,12HSTRAIN-TOTAL,3X,3(E14.6,2X))
  7509.  2029 FORMAT (37X,7HPLASTIC,3X,3(E14.6,2X))
  7510.  2030 FORMAT (///,40H S E C T I O N   P R O P E R T Y             ///,
  7511.      1       2X,4HTYPE,6X,9HPROP(1)=E,4X,11HPROP(2)=XNU,5X,10HPROP(3)=DO
  7512.      2,      5X,10HPROP(4)=DI/)
  7513.  2031 FORMAT (32X,15HYIELD STRESS = ,E14.6,2X,
  7514.      1        29HACCUM. EFF. PLASTIC STRAIN = ,E14.6,/)
  7515.  2100 FORMAT (//,1X,30HS E C T I O N  P R O P E R T Y,//,2X,4HTYPE,4X,
  7516.      1        11HPROP(1) = E,4X,13HPROP(2) = XNU,3X,12HPROP(3) = DO,
  7517.      2        4X,12HPROP(4) = DI,8X,
  7518.      3        36HPIECEWISE-LINEAR STRESS-STRAIN CURVE,/,77X,6HSTRESS,
  7519.      4        10X,6HSTRAIN,11X,2HET)
  7520.  2110 FORMAT (//,1X,I5,6(2X,E14.6))
  7521.  2120 FORMAT (70X,3(2X,E14.6))
  7522.  2200 FORMAT (//,17H   STRESS TABLE (,I3,3H  )/)
  7523.  2201 FORMAT (10X,16I5)
  7524.  2210 FORMAT (//,45H M O M E N T  R E L E A S E  T A B L E S        //,
  7525.      1        5X,5HTABLE//)
  7526.  2220 FORMAT (5X,7I5)
  7527.  2400 FORMAT (///16H ELEMENT GROUP =,I2, 15H  (BEAM / BMEL)/
  7528.      1        19H ALTHOUGH NPAR(6) =,I2,22H, NONE OF THE ELEMENTS/
  7529.      2        49H IN THIS GROUP REFERS TO SKEW COORDINATE SYSTEMS./
  7530.      3        50H IT IS ADVISED THAT NPAR(6) BE SET TO ZERO TO SAVE,
  7531.      4        15H STORAGE SPACE.//
  7532.      5        39H THIS IS ONLY AN INFORMATIONAL MESSAGE.///)
  7533.  2410 FORMAT (///16H ELEMENT GROUP =,I2,15H  (BEAM / BMEL)/
  7534.      1        16H ELEMENT NUMBER=,I4/10H NPAR(6) =,I2//
  7535.      2        53H SINCE NODES OF THIS ELEMENT REFER TO SKEW COORDINATE/
  7536.      3        37H SYSTEM(S), NPAR(6) MUST BE SET TO 1.//8H S T O P)
  7537. C
  7538.  3000 FORMAT (1H1,///47H *** ERROR IN BEAM MATERIAL PROPERTY INPUT DATA/
  7539.      1        9H SET NO =,I5,10H  ISHEAR =,I5//)
  7540.  3401 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
  7541.      2          19H ELEMENT GROUP NO =,I5/
  7542.      3          27H MATERIAL PROPERTY SET NO =,I5/
  7543.      1  58H INNER DIAMETER OF PIPE SECTION IS GREATER OR EQUAL TO      ,
  7544.      2  16H OUTER DIAMETER   //)
  7545.  3402 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
  7546.      2          19H ELEMENT GROUP NO =,I5/
  7547.      3          27H MATERIAL PROPERTY SET NO =,I5/
  7548.      4  38H ZERO OR NEGATIVE INITIAL YIELD STRESS  //)
  7549.  3403 FORMAT (//50H INPUT ERROR DETECTED IN (BMEL/BEAM)               //
  7550.      2          19H ELEMENT GROUP NO =,I5/
  7551.      3          27H MATERIAL PROPERTY SET NO =,I5/
  7552.      4  60H HARDENING MODULUS (ET) GREATER OR EQUAL TO  YOUNG S MODULUS,
  7553.      5  30H  (E) IS NOT ALLOWED.           //)
  7554.  3404 FORMAT (//45H INPUT ERROR IN MATERIAL/SECTION PROPERTIES     //
  7555.      1          15H *** STOP ***     //)
  7556.  3500 FORMAT(///23H INPUT ERROR **********/
  7557.      1          19H SUBSTRUCTURE  NO =,I3/
  7558.      2          19H ELEMENT GROUP NO =,I3/
  7559.      3          31H FIRST ELEMENT NUMBER MUST BE 1)
  7560. C
  7561.       END
  7562.