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