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