Liren Large Software Subsidy 9/09.iso/e/e001/1.ddi/TMP/ADINA12.FOR

Text File | 1991-01-07 | 218.8 KB | 7,579 lines

C *CDC* *DECK DIRCOS
C *UNI* )FOR,IS N.DIRCOS,R.DIRCOS
      SUBROUTINE DIRCOS (RSDCOS,EDIS,ISKEW,NODES,NDPN,IPER)
C
C     THIS SUBROUTINE TRANSFORMS DISPLACEMENTS FROM SKEW
C     CO-ORDINATE DIRECTIONS TO GLOBAL CO-ORDINATE DIRECTIONS
C     AND VICE VERSA FOR FORCES
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /XATKA/ LMID(32)
      DIMENSION RSDCOS(9,1),EDIS(1),ISKEW(1),ED(3)
C
      IF (NPAR(1).EQ.7) GO TO 10
      DO 5 I=1,NODES
    5 LMID(I)=1
C
   10 JUMD=0
      NF=0
      IF (NDPN.EQ.2) NF=4
C
      DO 100 N=1,NODES
      NR=ISKEW(N)
      IF (NR) 200,100,20
   20 L=NDPN*(N-1) + JUMD
      DO 25 I=1,NDPN
   25 ED(I)=EDIS(L+I)
C
      IF (IPER.EQ.2) GO TO 70
C
C     DISPLACEMENT TRANSFORMATION
C
      DO 50 I=1,NDPN
      LI=L+I
      EDIS(LI)=0.
      MM=NF+I
      DO 40 J=1,NDPN
      EDIS(LI)=EDIS(LI) + RSDCOS(MM,NR)*ED(J)
   40 MM=MM+3
   50 CONTINUE
      GO TO 100
C
C     FORCE TRANSFORMATION
C
   70 MM=NF+1
      DO 80 I=1,NDPN
      LI=L+I
      EDIS(LI)=0.
      DO 75 J=1,NDPN
      EDIS(LI)=EDIS(LI) + RSDCOS(MM,NR)*ED(J)
   75 MM=MM+1
   80 MM=MM + (3-NDPN)
C
C
      IF (LMID(N).LT.0) JUMD=JUMD + 2
  100 CONTINUE
C
  200 RETURN
C
C
      END
C *CDC* *DECK ADDMA
C *UNI* )FOR,IS  N.ADDMA,  R.ADDMA
      SUBROUTINE ADDMA (A,S,LM,ND)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DPR/ ITWO
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /FACDBL/ JFAC
      COMMON AA(1)
      REAL AA
      INTEGER IA(1)
      EQUIVALENCE (AA(1),IA(1))
      DIMENSION A(1),S(1),LM(1)
C
C
C     ADD ELEMENT MASS TO GLOBAL LUMPED MASS VECTOR
C
      DO 100 I=1,ND
      II=LM(I)
      IF (II) 50,100,110
C
C     TRANSFER MASS FROM CONSTRAINED DEGREE OF FREEDOM
C
   50 NCE=-II
      NID=IA(N01 + NCE - 1)
      NN=N02 + (NCE - 1)*NIDM - 1
      MM=N03 + ((NCE - 1)*NIDM - 1)*ITWO
      DO 70 J=1,NID
      II=IA(NN + J)
      FAC=DOUBLE(AA(MM + J*ITWO))
      FACTOR=FAC*FAC
      IF (JFAC.EQ.1) FACTOR=FAC
      A(II)=A(II) + S(I)*FACTOR
   70 CONTINUE
      GO TO 100
C
  110 A(II)=A(II) + S(I)
  100 CONTINUE
      RETURN
C
      END
C *CDC* *DECK MULT
C *UNI* )FOR,IS  N.MULT,   R.MULT
      SUBROUTINE MULT (A,B,C,MAXA,NCOLBV,NEQ,MDIM,NBLOCK,NTAPE)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .     .  TO CALCULATE  A = A - B*C , WHERE B IS STORED IN           .
C .        COMPACTED FORM  ,  A  AND  C  ARE VECTORS                  .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(MDIM),C(1)
      INTEGER MAXA(1),NCOLBV(1)
C
      IF (NEQ.GT.1) GO TO 10
      READ (NTAPE) B
      A(1)=A(1) - B(1)*C(1)
      RETURN
C
   10 NEQL=1
      NEQR=0
      MLA=0
      DO 40 L=1,NBLOCK
      READ (NTAPE) B
      NEQR=NEQR + NCOLBV(L)
      DO 100 I=NEQL,NEQR
      KL=MAXA(I) - MLA
      KU=MAXA(I+1) - 1 - MLA
      II=I + 1
      CC=C(I)
      DO 100 KK=KL,KU
      II=II - 1
  100 A(II)=A(II) - B(KK)*CC
      DO 200 I=NEQL,NEQR
      KL=MAXA(I) + 1 - MLA
      KU=MAXA(I+1) - 1 - MLA
      IF (KU-KL) 200,210,210
  210 II=I
      AA=0.
      DO 220 KK=KL,KU
      II=II - 1
  220 AA=AA + B(KK)*C(II)
      A(I)=A(I) - AA
  200 CONTINUE
      NEQL=NEQL + NCOLBV(L)
      MLA=MAXA(NEQL) - 1
   40 CONTINUE
C
      RETURN
      END
C *CDC* *DECK CROSS
C *UNI* )FOR,IS N.CROSS,R.CROSS
      SUBROUTINE CROSS (X,Y,Z)
C
C     CROSS PRODUCT OF VECTORS X AND Y, STORED IN Z
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(1),Y(1),Z(1)
C
      Z(1)=X(2)*Y(3)-X(3)*Y(2)
      Z(2)=X(3)*Y(1)-X(1)*Y(3)
      Z(3)=X(1)*Y(2)-X(2)*Y(1)
      RETURN
C
      END
C *CDC* *DECK ELEMNT
C *UNI* )FOR,IS  N.ELEMNT, R.ELEMNT
      SUBROUTINE ELEMNT
C
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE(A(1),IA(1))
C
      IF (IND.EQ.0) GO TO 110
      NFIRST=N6
      IF (IND.EQ.4) NFIRST=N10
      DO 100 I=1,20
  100 NPAR(I)=IA(NFIRST + I - 1)
C
  110 NPAR1=NPAR(1)
      GO TO (1, 2, 3, 4, 5, 6, 7, 10, 10, 10, 11, 12, 13), NPAR1
C
C *CDC*     1 CALL OVERLAY (5HADINA, 2B,0B,6HRECALL)
    1 CALL TRUSS
      RETURN
C
C *CDC*     2 CALL OVERLAY (5HADINA, 3B,0B,6HRECALL)
    2 CALL TODMFE
      RETURN
C
C *CDC*    3 CALL OVERLAY (5HADINA, 4B,0B,6HRECALL)
    3 CALL THREDM
      RETURN
C
C *CDC*     4 CALL OVERLAY (5HADINA, 5B,0B,6HRECALL)
    4 CALL BEAM
      RETURN
C
C *CDC*     5 CALL OVERLAY (5HADINA, 6B,0B,6HRECALL)
    5 CALL ISOBM
      RETURN
C
C *CDC*     6 CALL OVERLAY (5HADINA, 7B,0B,6HRECALL)
    6 CALL PLATE
      RETURN
C
C *CDC*     7 CALL OVERLAY (5HADINA,10B,0B,6HRECALL)
    7 CALL SHELL
      RETURN
C
C *CDC*    10 CALL OVERLAY (5HADINA,13B,0B,6HRECALL)
   10 CALL EMPTY
      RETURN
C
C *CDC*    11 CALL OVERLAY (5HADINA,14B,0B,6HRECALL)
   11 CALL TODMFL
      RETURN
C
C *CDC*    12 CALL OVERLAY (5HADINA,15B,0B,6HRECALL)
   12 CALL THDMFL
      RETURN
C
C *CDC*    13 CALL OVERLAY (5HADINA,16B,0B,6HRECALL)
C          NOT AVAILABLE TEMPORARILY
C  13 CALL CONTAC
C
   13 CONTINUE
      RETURN
C
C
      END
C *CDC* *DECK RSTART
C *UNI* )FOR,IS  N.RSTART,      R.RSTART
      SUBROUTINE RSTART (DISPE,DISP,VEL,ACC,EE,IGRBLC,NEQ,NBLOCK,KKK)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NEG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,IREF,
     1             IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
C
      DIMENSION DISPE(NEQ),DISP(NEQ),VEL(NEQ),ACC(NEQ),EE(1),
     1          IGRBLC(NBLOCK,1)
      REAL EE
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
      DATA RECLB1/8HRNORMALS/
C
      IF (KKK.EQ.2) GO TO 200
C
      IF (ISUB.GT.0) GO TO 160
      REWIND 8
      READ(8)
      IF (KLIN.EQ.0) GO TO 150
C
      IF (NBLOCK.GT.1)
     1 WRITE (8) ((IGRBLC(L,NG),L=1,NBLOCK),NG=1,NEGNL)
C
      NN=N1 - 1
      IF (MAXMSS.GT.0)
     1   WRITE (8) (A(I),I=N09,NN)
C
      DO 140 NG=1,NEGNL
      NUMEST=IA(N0 + NG - 1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC2=NG
      CALL READMS (2,EE,NUMEST,NREC2)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      WRITE (8) NUMEST,(EE(I),I=1,NUMEST)
  140 CONTINUE
C
  150 WRITE (8) ISTAT
      WRITE (8) DT
  160 WRITE (8) DISP
      IF (ISTAT.EQ.0) GO TO 188
      IF (IOPE.EQ.3) GO TO 170
      WRITE (8) VEL
      WRITE (8) ACC
      GO TO 188
  170 WRITE (8) DISPE
  188 RETURN
C
C     FOR RESTART JOBS READ IN NONLINEAR ELEMENT GROUP DATA CORRESPONDIN
C    -G TO TIME=TSTART
C
  200 IF (NEGNL.EQ.0) GO TO 220
C
      IF (NBLOCK.GT.1)
     1  READ (8) ((IGRBLC(L,NG),L=1,NBLOCK),NG=1,NEGNL)
C
      NN=N1 - 1
      IF (MAXMSS.GT.0)
     1   READ  (8) (A(I),I=N09,NN)
C
C***  DATA PORTHOLE (START)
C
      IF (MAXMSS.LE.0 .OR. JNPORT.EQ.0) GO TO 205
      RECLAB = RECLB1
      N1N09 = N1 - N09
      IF (KPLOTN.EQ.0 .AND. JDC.NE.0)
     1  WRITE (LUNODE) RECLAB,N1N09,(A(I),I=N09,NN)
  205 CONTINUE
C
C***  DATA PORTHOLE (END)
C
C
      DO 210 NG=1,NEGNL
      READ (8) NUMEST,(EE(I),I=1,NUMEST)
      IA(N0 + NG - 1)=NUMEST
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC2=NG
      CALL WRITMS (2,EE,NUMEST,NREC2,-1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  210 CONTINUE
  220 IF (ISUB.GT.0) GO TO 240
      READ (8) ISTATO
      READ (8) DTOD
  240 READ (8) DISP
C
      IF (ISTAT.EQ.0) GO TO 300
      IF (ISTATO.EQ.ISTAT) GO TO 280
C
      DO 260 IEQ=1,NEQ
      IF (IOPE.EQ.3) GO TO 250
      VEL(IEQ)=0.
      ACC(IEQ)=0.
      GO TO 260
  250 DISPE(IEQ)=DISP(IEQ)
  260 CONTINUE
      GO TO 300
C
  280 IF (IOPE.EQ.3) GO TO 290
      READ (8) VEL
      READ (8) ACC
      GO TO 300
  290 READ (8) DISPE
  300 RETURN
C
      END
C *CDC* *DECK ECHECK
C *UNI* )FOR,IS N.ECHECK,R.ECHECK
      SUBROUTINE ECHECK (LM,ND,ICODE,IUPDT)
C
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DISCON/ NDISCE,NIDM
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      INTEGER LM(1)
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
C
      IUPDT=0
C
      ICODE=1
      IF (NBLOCK.GT.1) GO TO 10
      ICODE=0
      RETURN
C
   10 DO 100 I=1,ND
      II=LM(I)
      IF (II) 15,40,40
C
   15 NCE=-II
      NID=IA(N01 + NCE - 1)
      NN=N02 + (NCE - 1)*NIDM - 1
      DO 30 J=1,NID
      II=IA(NN + J)
      IF (II.GT.NEQR) IUPDT=1
      IF (II - NEQL) 30,20,20
   20 IF (II - NEQR) 25,25,30
   25 ICODE=0
   30 CONTINUE
      GO TO 100
C
   40 IF (II.GT.NEQR) IUPDT=1
      IF (II - NEQL) 100,50,50
   50 IF (II - NEQR) 60,60,100
   60 ICODE=0
  100 CONTINUE
C
      RETURN
      END
C *CDC* *DECK TCHECK
C *UNI* )FOR,IS  N.TCHECK, R.TCHECK
      SUBROUTINE TCHECK (TTIME,ATIME)
C
C     THIS SUBROUTINE CHECKS THE TIME ON THE TEMPERATURE TAPE
C     (TTIME) WITH THE TIME IN ADINA (ATIME)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      IF(DABS(TTIME-ATIME).LT.1.0D-10) RETURN
C
      WRITE (6,2000) TTIME,ATIME
      STOP
C
 2000 FORMAT (///,1X,41H@@STOP@@ INCOMPATIBILITY BETWEEN TIME OF
     1               44HSOLUTION AND TIME AT WHICH THE TEMPERATURES
     2               11HARE DEFINED //
     3               12H TAPE TIME =,E15.8,14H  ADINA TIME =,E15.8  )
C
      END
C *CDC* *DECK BLKCNT
C *UNI* )FOR,IS N.BLKCNT, R.BLKCNT
      SUBROUTINE BLKCNT(KSTEP,NUMBLK,KCNTL,IBLOCK,NSTE,INDEX)
C
C     PROGRAM TO DETERMINE THE VALUE (EITHER 0 OR 1) OF THE
C        CONTROL VARIABLE FOR ANY OF THE FIVE CONTROLS - STIFFNESS
C        REFORMATION, EQUILIBRIUM ITERATION, PRINT-OUT, NODAL
C        RESPONSE SAVING AND ELEMENT RESPONSE SAVING.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION IBLOCK(3,10),RNAME(5)
C
      DATA RNAME /8HSTIFNESS, 8HITERATON, 8HPRINTOUT, 8HNODESAVE,
     1           8HELMTSAVE/
      KCNTL = 1
      IF (NUMBLK .EQ. 0) RETURN
C
      DO 100 I=1,NUMBLK
      IF(KSTEP.LE.IBLOCK(2,I)) GO TO 110
  100 CONTINUE
      WRITE (6,3000) RNAME(INDEX),NSTE
      STOP
C
  110 NINT=(IBLOCK(2,I)-IBLOCK(1,I))/IBLOCK(3,I) + 1
      DO 200 J=1,NINT
      LCNTL=IBLOCK(1,I) + (J-1)*IBLOCK(3,I)
      IF(KSTEP-LCNTL) 210,120,200
  120 KCNTL = 0
      GO TO 210
  200 CONTINUE
C
  210 RETURN
C
 3000 FORMAT(1H1,21H ** STOP ** ERROR IN ,A10,58H BLOCK INPUT. FINAL STE
     1P OF LAST BLOCK INPUT IS LESS THAN, I5)
      END
C *UNI* )FOR,IS N.WRITMS, R.WRITMS
      SUBROUTINE WRITMS (NTAPE,AA,LNTH,NREC,KKK)
C
C     SUBROUTINE FOR R A N D O M  A C C E S S WRITING IN IBM
C
      COMMON /DPR/ ITWO
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /SRANDI/ N09A,N09B
      COMMON /RANDAC/ NR(5),LR(5)
      COMMON A(1)
      REAL A,AA(1)
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
C     OBTAIN RECORD NUMBER FROM BLANK COMMON
C
      LN=LNTH
      GO TO (3, 2, 3, 3, 3, 3, 3, 3, 3,10, 3, 3, 3, 3, 3,16,17),
     1       NTAPE
C
    3 WRITE (6,3000) NTAPE
      STOP
    2 NTM=1
      NST=N0A
      GO TO 20
   10 NTM=2
      NST=N1D
      LN=LN*ITWO
      GO TO 20
   16 NTM=3
      NST=N09A
      LN=LN*ITWO
      GO TO 20
   17 NTM=4
      NST=N09B
      LN=LN*ITWO
C
C     BREAK CURRENT FORTRAN RECORD NREC INTO SMALLER
C     LOGICAL RECORDS OF SIZE LR(NTM) AND WRITE ONTO TAPE NTAPE,
C     STARTING FROM LOGICAL RECORD NUMBER IREC ONWARDS
C
   20 IREC=1
      IF (NREC.GT.1) IREC=IA(NST + NREC - 1)
      II=1
   30 JJ=II - 1 + LR(NTM)
      IF (JJ.GT.LN) JJ=LN
      IF (IREC.GT.NR(NTM)) GO TO 998
C
      IDUM=IREC
      WRITE (NTAPE'IDUM) (AA(I),I=II,JJ)
C
      IREC=IREC + 1
      II=JJ + 1
      IF (II.LE.LN) GO TO 30
      IA (NST+NREC)=IREC
      RETURN
C
  998 WRITE (6,3100) NTAPE,IREC,NR(NTM),NTM
      STOP
C
 3000 FORMAT (1H1,39H ***STOP***, ERROR IN RANDOM ACCESS I/O,/,
     1        41H SUBROUTINE WRITMS CALLED FOR UNIT NUMBER,I4,
     2        36H WHICH IS NOT A RANDOM ACCESS DEVICE   )
 3100 FORMAT (1H1,43H ***STOP***, LIMIT OF STORAGE ALLOCATED FOR
     1 32H RANDOM ACCESS HAS BEEN REACHED.,/,12H FOR UNIT NO,I4,
     2 22H CURRENT RECORD NUMBER,I5,8H EXCEEDS,I5,/,1X,
     3 54HFOR EXECUTING THIS PROBLEM INCREASE DIMENSION OF NREC(
     4 I2,23H) IN MAIN PROGRAM ADINA   )
C
      END
C *UNI* )FOR,IS N.READMS, R.READMS
      SUBROUTINE READMS (NTAPE,AA,LNTH,NREC)
C
C     SUBROUTINE FOR R A N D O M  A C C E S S READING IN IBM
C
      COMMON /DPR/ ITWO
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /SRANDI/ N09A,N09B
      COMMON /RANDAC/ NR(5),LR(5)
      COMMON A(1)
      REAL A,AA(1)
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
C     OBTAIN LOGICAL RECORD NUMBER FROM BLANK COMMON
C
      LN=LNTH
      GO TO (3, 2, 3, 3, 3, 3, 3, 3, 3,10, 3, 3, 3, 3, 3,16,17),
     1       NTAPE
C
    3 WRITE (6,3000) NTAPE
      STOP
    2 NTM=1
      NST=N0A
      GO TO 20
   10 NTM=2
      NST=N1D
      LN=LN*ITWO
      GO TO 20
   16 NTM=3
      NST=N09A
      LN=LN*ITWO
      GO TO 20
   17 NTM=4
      NST=N09B
      LN=LN*ITWO
C
C     READ CURRENT FORTRAN RECORD FROM MORE THAN ONE LOGICAL
C     RECORD OF LENGTH LR(NTM) FROM TAPE NTAPE, STARTING FROM
C     LOGICAL RECORD IREC, IF NECESSARY.
C
   20 IREC=1
      IF (NREC.GT.1) IREC=IA(NST + NREC - 1)
      II=1
   30 JJ=II - 1 + LR(NTM)
      IF (JJ.GT.LN) JJ=LN
      IF (IREC.GT.NR(NTM)) GO TO 998
C
      IDUM=IREC
      READ (NTAPE'IDUM) (AA(I),I=II,JJ)
C
      IREC=IREC + 1
      II=JJ + 1
      IF (II.LE.LN) GO TO 30
      RETURN
C
  998 WRITE (6,3100) NTAPE,IREC,NR(NTM),NTM
      STOP
C
 3000 FORMAT (1H1,39H ***STOP***, ERROR IN RANDOM ACCESS I/O,/,
     1        41H SUBROUTINE READMS CALLED FOR UNIT NUMBER ,I4,
     2        36H WHICH IS NOT A RANDOM ACCESS DEVICE    )
 3100 FORMAT (1H1,43H ***STOP***, LIMIT OF STORAGE ALLOCATED FOR
     1 32H RANDOM ACCESS HAS BEEN REACHED.,/,12H FOR UNIT NO,I4,
     2 22H CURRENT RECORD NUMBER,I5,8H EXCEEDS,I5,/,1X,
     3 54HFOR EXECUTING THIS PROBLEM INCREASE DIMENSION OF NREC(
     4 I2,23H) IN MAIN PROGRAM ADINA   )
C
      END
      SUBROUTINE CPUINT
      IMPLICIT REAL*8 (A-H,O-Z)
C     CALL STIME
      RETURN
      END
C *CDC* *DECK OVL10
C *CDC*      OVERLAY (ADINA,1,0)
C *CDC* *DECK ADINI
C *UNI* )FOR,IS  N.ADINI, R.ADINI
C *CDC*      PROGRAM ADINI
      SUBROUTINE ADINI
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON /TEMP/ ISPEC
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PRCONS/ IPRICS
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MDFRDM/ IDOF(6)
      COMMON /DPR/ ITWO
      COMMON /BLOCKS/ NSREFB,NEQITB,NPRIB,NODSVB,LEMSVB,ISREFB(3,10),
     1                IEQITB(3,10),IPRIB(3,10),INODB(3,10),IELMB(3,10)
      COMMON /SKEW/ NSKEWS
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /PORTT/ JTC
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /NMDATA/ KSET
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
      DIMENSION BLKNAM(5), WORD(6)
      DATA WORD / 3H   ,3HNON,6HLINEAR,5H STAT,5HDYNAM,3HIC  /
      DATA BLKNAM /8HSTIFNESS,8HITERATON,8HPRINTOUT,
     1             8HNODESAVE,8HELMTSAVE/
      DATA RECLB1/8HMASTERCP/,RECLB2/8HID-ARRAY/
      DATA IFINAL /4HSTOP/
C
C
      IF (ISUB.GT.0) GO TO 900
C
C
C     R E A D   C O N T R O L   I N F O R M A T I O N
C
C
C *CDC*   IREAD=50
C
C *CDC*   THE ABOVE CARD IS USED IF EDITING OF COMMENTS FROM
C *CDC*   THE INPUT STREAM IS POSSIBLE
C *CDC*   OTHERWISE THE FOLLOWING CARD IS ACTIVATED
C *CDC*           IREAD=5
C
      IREAD=5
C
      IF (KSET.GT.0) IREAD=5
      READ (IREAD,1000) IHED
      IF (IHED(1).EQ.IFINAL) STOP
      READ (IREAD,1003) NUMNP,(IDOF(I),I=1,6),NEGL,NEGNL,MODEX,NSTE,DT,
     1              TSTART,IDATWR,NSUBST,NSKEWS,NMIDSS,ISTOTE
      IF (NUMNP.EQ.0) STOP
      IF (KSET.EQ.0) CALL INLIST (IDATWR,2)
      READ (5,1001) IRINT,ITP96,INPORT,JNPORT
      READ (5,1010) NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,
     1              IDGRAV,NPDIS,NTEMP,NDISCE,NIDM
      READ (5,1001) IMASS,IDAMP,IMASSN
      READ (5,1002) IEIG,IESTYP,NFREQ,NQ,NMODE,IFPR,IRBM,RBMSH,COFQ
      READ (5,1020) IMODES,IOPE,OPVAR(1),OPVAR(2),NMODES,IMDAMP
      READ (5,1005) NSREFB,NEQITB,METHOD,IATKEN,ITEMAX,NLSTPD,DTOL,
     1              RTOL,STOL,RNORM
      READ (5,1010) IOUTPT,NPRIB,NPB,IDC,IVC,IAC,ISTPRT
      READ (5,1010) NPUTSV,NODSVB,LEMSVB,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
     1              ,JTC
C
      IF (NSREFB.EQ.0) GO TO 250
      READ (5,1100)((ISREFB(I,J),I=1,3),J=1,NSREFB)
      IF (NSTE.GT.0 .AND. ISREFB(1,1).EQ.0) ISREFB(1,1)=1
      IF (ISREFB(2,1) .EQ. 0) ISREFB(2,1) = NSTE
      IF (ISREFB(3,1) .EQ. 0) ISREFB(3,1) = 1
      INDEX=1
      IF (NSREFB.LE.1) GO TO 240
      DO 230 I=2,NSREFB
      J=I - 1
      IF (ISREFB(1,J).GT.ISREFB(2,J)) GO TO 235
      IF (ISREFB(1,I).GE.ISREFB(2,J)) GO TO 230
      WRITE (6,3000) BLKNAM(INDEX),I,J
      STOP
  230 CONTINUE
  240 J=NSREFB
      IF (ISREFB(1,J).LE.ISREFB(2,J)) GO TO 245
  235 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  245 IF (ISREFB(2,NSREFB).GE.NSTE) GO TO 250
      WRITE (6,3001) BLKNAM(INDEX),ISREFB(2,NSREFB),NSTE
      STOP
C
C
C     SPECIAL CASE  (EQUATION SOLUTION TECHNIQUE)
C     SPECIAL CASE   FOR NOW REARRANGE EQUATIONS ONLY FOR
C     SUBSTRUCTURING
C
  250 ISPEC=1
      IF (NSUBST.GT.0 .AND. IMASS.GT.0) ISPEC=0
      IF (NEGNL.EQ.0) ISPEC=0
C
  260 IF (NEQITB.EQ.0) GO TO 350
      READ (5,1100)((IEQITB(I,J),I=1,3),J=1,NEQITB)
      IF (NSTE.GT.0 .AND. IEQITB(1,1).EQ.0) IEQITB(1,1)=1
      IF (IEQITB(2,1) .EQ. 0) IEQITB(2,1) = NSTE
      IF (IEQITB(3,1) .EQ. 0) IEQITB(3,1) = 1
      INDEX=2
      IF (NEQITB.LE.1) GO TO 340
      DO 330 I=2,NEQITB
      J=I - 1
      IF (IEQITB(1,J).GT.IEQITB(2,J)) GO TO 335
      IF (IEQITB(1,I).GE.IEQITB(2,J)) GO TO 330
      WRITE (6,3000) BLKNAM(INDEX),I,J
      STOP
  330 CONTINUE
  340 J=NEQITB
      IF (IEQITB(1,J).LE.IEQITB(2,J)) GO TO 345
  335 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  345 IF (IEQITB(2,NEQITB).GE.NSTE) GO TO 350
      WRITE (6,3001) BLKNAM(INDEX),IEQITB(2,NEQITB),NSTE
      STOP
C
  350 IF (NPRIB .EQ.0) GO TO 450
      READ (5,1100)((IPRIB(I,J),I=1,3),J=1,NPRIB)
      IF (NSTE.GT.0 .AND. IPRIB(1,1).EQ.0) IPRIB(1,1)=1
      IF ( IPRIB(2,1) .EQ. 0)  IPRIB(2,1) = NSTE
      IF ( IPRIB(3,1) .EQ. 0)  IPRIB(3,1) = 1
      INDEX=3
      IF (NPRIB.LE.1) GO TO 440
      DO 430 I=2,NPRIB
      J=I - 1
      IF (IPRIB(1,J).GT.IPRIB(2,J)) GO TO 435
      IF (IPRIB(1,I).GE.IPRIB(2,J)) GO TO 430
      WRITE (6,3000) BLKNAM(INDEX),I,J
      STOP
  430 CONTINUE
  440 J=NPRIB
      IF (IPRIB(1,J).LE.IPRIB(2,J)) GO TO 445
  435 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  445 IF (IPRIB(2,NPRIB).GE.NSTE) GO TO 450
      WRITE (6,3001) BLKNAM(INDEX),IPRIB(2,NPRIB),NSTE
      STOP
C
  450 IF (NPB   .EQ.0) GO TO 550
      READ (5,1100) ((IPNODE(I,J),I=1,3),J=1,NPB)
      IF (IPNODE(1,1).EQ.0) IPNODE(1,1)=1
      IF (IPNODE(2,1).EQ.0) IPNODE(2,1)=NUMNP
      IF (IPNODE(3,1).LE.0) IPNODE(3,1)=1
      DO 500 I=1,NPB
      IF (IPNODE(1,I).LT.0) GO TO 510
      IF (IPNODE(1,I).GT.IPNODE(2,I)) GO TO 510
      IF (IPNODE(3,I).LE.0) GO TO 510
  500 CONTINUE
      GO TO 550
  510 WRITE (6,2990)
      STOP
  550 IF (JNPORT.EQ.0 .OR. NODSVB.EQ.0) GO TO 650
      READ (5,1100)((INODB(I,J),I=1,3),J=1,NODSVB)
      IF (NSTE.GT.0 .AND. INODB(1,1).EQ.0) INODB(1,1)=1
      IF ( INODB(2,1) .EQ. 0)  INODB(2,1) = NSTE
      IF ( INODB(3,1) .EQ. 0)  INODB(3,1) = 1
      INDEX=4
      IF (NODSVB.LE.1) GO TO 640
      DO 630 I=2,NODSVB
      J=I - 1
      IF (INODB(1,J).GT.INODB(2,J)) GO TO 635
      IF (INODB(1,I).GE.INODB(2,J)) GO TO 630
      WRITE (6,3000) BLKNAM(INDEX),I,J
      STOP
  630 CONTINUE
  640 J=NODSVB
      IF (INODB(1,J).LE.INODB(2,J)) GO TO 645
  635 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  645 IF (INODB(2,NODSVB).GE.NSTE) GO TO 650
      WRITE (6,3001) BLKNAM(INDEX),INODB(2,NODSVB),NSTE
      STOP
C
  650 IF (JNPORT.EQ.0 .OR. LEMSVB.EQ.0) GO TO 750
      READ (5,1100)((IELMB(I,J),I=1,3),J=1,LEMSVB)
      IF (NSTE.GT.0 .AND. IELMB(1,1).EQ.0) IELMB(1,1)=1
      IF ( IELMB(2,1) .EQ. 0)  IELMB(2,1) = NSTE
      IF ( IELMB(3,1) .EQ. 0)  IELMB(3,1) = 1
      INDEX=5
      IF (LEMSVB.LE.1) GO TO 740
      DO 730 I=2,LEMSVB
      J=I - 1
      IF (IELMB(1,J).GT.IELMB(2,J)) GO TO 735
      IF (IELMB(1,I).GE.IELMB(2,J)) GO TO 730
      WRITE (6,3000) BLKNAM(INDEX),I,J
      STOP
  730 CONTINUE
  740 J=LEMSVB
      IF (IELMB(1,J).LE.IELMB(2,J)) GO TO 745
  735 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  745 IF (IELMB(2,LEMSVB).GE.NSTE) GO TO 750
      WRITE (6,3001) BLKNAM(INDEX),IELMB(2,LEMSVB),NSTE
      STOP
  750 CONTINUE
C
C     VERIFY AND INITIALIZE SOLUTION VARIABLES
C
      IF (NEGL.GT.0 .OR. NEGNL.GT.0 .OR. NSUBST.GT.0) GO TO 48
      WRITE (6,3090)
      STOP
   48 IF (NSUBST.LE.0 .OR. NDISCE.LE.0) GO TO 52
      WRITE (6,3091)
      IF (MODEX.EQ.0) GO TO 52
      STOP
   52 NUMEG=NEGL + NEGNL
      IDAMPN=IDAMP
      NDOF=6
      DO 1 I=1,6
    1 NDOF=NDOF - IDOF(I)
      ISTAT=1
      IF (IMASS.EQ.0) ISTAT=0
      IF (ISTAT.EQ.1 .AND. IOPE.EQ.0) IOPE=2
      IF (IMODES.GT.0) IOPE=2
      IF (IOPE.NE.3 .OR. IMASS.EQ.1) GO TO 20
      WRITE (6,3012)
      STOP
   20 DTA=DT
      KLIN=1
      IF (NEGNL.EQ.0) KLIN=0
      IF (IEIG.GT.0 .AND. NFREQ.EQ.0) NFREQ=1
      IF (COFQ.EQ.0) COFQ=1.D+08
      IF (IOPE.NE.3 .OR. IEIG.EQ.0) GO TO 2
      WRITE (6,3010)
      STOP
    2 IF (IEIG.LE.1) GO TO 3
      WRITE(6,3003)
      STOP
    3 IF (NSUBST.EQ.0 .OR. IEIG.EQ.0) GO TO 4
      WRITE (6,3013) NSUBST,IEIG
      STOP
    4 IF (ITP96.EQ.2) GO TO 24
      IF (NTEMP.EQ.0) GO TO 24
      WRITE (6,3014) ITP96,NTEMP
      STOP
   24 IF (IDGRAV.EQ.0 .OR. ISTAT.EQ.0) GO TO 25
      IF (IMASS.EQ.1) GO TO 25
      WRITE (6,3020)
      STOP
   25 IF (IOPE.NE.3 .OR. NSUBST.EQ.0) GO TO 40
      WRITE (6,3030)
      STOP
C
   40 NODE3=12
      NC=NFREQ + 8
      IF (NC.GT.2*NFREQ) NC=2*NFREQ
      IF (IESTYP.EQ.1 .AND. NQ.EQ.0) NQ=NC
C
      IF (METHOD.EQ.0) METHOD=1
      IF (METHOD.EQ.2) IATKEN=0
      NLSTPD=0
      IF (ITEMAX.EQ.0) ITEMAX=15
      IF (DTOL.EQ.0.0) DTOL=0.01
      IF (RTOL.EQ.0.0) RTOL=0.01
      IF (STOL.EQ.0.0) STOL=0.5
      ETOL=10.0*RTOL*DTOL
      IF (IRINT.EQ.0) IRINT=9999
C
      IF(MODEX.NE.2 .AND. JNPORT.GT.0) NPUTSV=1
      IF (LUNODE .EQ. 0) LUNODE=60
C
      IF (LU1    .EQ.0) LU1    = 60
      IF (LU2    .EQ.0) LU2    = 60
      IF (LU3    .EQ.0) LU3    = 60
C
C***  DATA PORTHOLE (START)
C
      IF (JNPORT.EQ.0) GO TO 790
      RECLAB=RECLB1
      WRITE (LUNODE) RECLAB,(IHED(I),I=1,18),NUMNP,(IDOF(I),I=1,6),
     1               NEGL,NEGNL,MODEX,NSTE,DT,TSTART,IDATWR,NSKEWS,
     2               IRINT,ITP96,INPORT,JNPORT,IMASS,IDAMP,IMASSN,
     3               IEIG,NSREFB,NEQITB,RTOL,ITEMAX,IOPE,OPVAR(1),
     4               OPVAR(2),NPRIB,NODSVB,LEMSVB,LUNODE,LU1,LU2,LU3,
     5               NPB,IDC,IVC,IAC,NPUTSV,JDC,JVC,JAC,
     6               ((IPNODE(I,J),I=1,3),J=1,NPB),
     7               NMIDSS,NDISCE,NSUBST,JTC,NFREQ,ISTAT
      RECLAB=BLKNAM(1)
      IF (NSREFB.NE.0) WRITE(LUNODE) RECLAB,((ISREFB(I,J),I=1,3),
     1   J=1,NSREFB)
      RECLAB=BLKNAM(2)
      IF (NEQITB.NE.0) WRITE(LUNODE) RECLAB,((IEQITB(I,J),I=1,3),
     1   J=1,NEQITB)
      RECLAB=BLKNAM(3)
      IF (NPRIB.NE.0) WRITE(LUNODE) RECLAB,((IPRIB(I,J),I=1,3),
     1   J=1,NPRIB)
      RECLAB=BLKNAM(4)
      IF (NODSVB.NE.0) WRITE(LUNODE) RECLAB,((INODB(I,J),I=1,3),
     1   J=1,NODSVB)
      RECLAB=BLKNAM(5)
      IF (LEMSVB.NE.0) WRITE(LUNODE) RECLAB,((IELMB(I,J),I=1,3),
     1   J=1,LEMSVB)
C
C***  DATA PORTHOLE (END)
C
  790 WRITE (6,2000) IHED
C
C     SET TIME INTEGRATION COEFFICIENTS IN CASE OF DYNAMIC PROBLEM
C
      A0=0.
      A1=0.
      IF (ISTAT.EQ.0) GO TO 10
      CALL OPCOEF(OPVAR)
C
   10 CONTINUE
      WRITE(6,2005)
      NCARD=1
      WRITE (6,2010) NCARD
      WRITE(6,2015) NUMNP,(IDOF(I),I=1,6),NEGL,NEGNL,MODEX
      WRITE (6,2020) NSTE,DT,TSTART,IDATWR
      WRITE (6,2025) NSUBST,NSKEWS,NMIDSS
      NCARD=NCARD + 1
      WRITE (6,2010) NCARD
      WRITE (6,2028) IRINT,ITP96,INPORT,JNPORT
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2030) NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,IDGRAV,
     1               NPDIS,NTEMP,NDISCE,NIDM
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2035) IMASS,IDAMP,IMASSN
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2040) IEIG,IESTYP,NFREQ
      WRITE (6,2042) NQ,NMODE,IFPR,IRBM,RBMSH,COFQ
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2045) IMODES,IOPE
      IF (IMASS.EQ.0) IMODES=0
      IF (IOPE.EQ.1) WRITE(6,2050) OPVAR(1)
      IF (IOPE.EQ.2) WRITE(6,2055) OPVAR(1),OPVAR(2)
      WRITE (6,2057) NMODES,IMDAMP
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2060) NSREFB,NEQITB,METHOD,IATKEN
      WRITE (6,2061) ITEMAX,NLSTPD,DTOL,RTOL,STOL,RNORM
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2065) IOUTPT,NPRIB,NPB,IDC,IVC,IAC
      WRITE (6,2066) ISTPRT
      NCARD=NCARD + 1
      WRITE(6,2010) NCARD
      WRITE (6,2100) NPUTSV,NODSVB,LEMSVB
      WRITE (6,2105) LUNODE,LU1,LU2,LU3,JDC,JVC,JAC,JTC
      I=KLIN + 1
      J=ISTAT + 4
      WRITE (6,2110) WORD(I),WORD(3),WORD(J),WORD(6)
C
      IF (NSREFB.NE.0 .OR. NEQITB.NE.0) GO TO 810
      IF ( NPRIB.NE.0 .OR. JNPORT.NE.0) GO TO 810
      IF (NPB.GT.0) GO TO 810
      GO TO 890
C
  810 WRITE (6,2115)
  820 IF (NSREFB.EQ.0) GO TO 830
      WRITE (6,2120)
      WRITE (6,2130) (J,(J,ISREFB(I,J),I=1,3),J=1,NSREFB)
  830 IF (NEQITB.EQ.0) GO TO 840
      WRITE (6,2140)
      WRITE (6,2150) (J,(J,IEQITB(I,J),I=1,3),J=1,NEQITB)
  840 IF (NPRIB.EQ.0) GO TO 850
      WRITE (6,2160)
      WRITE (6,2170) (J,(J, IPRIB(I,J),I=1,3),J=1,NPRIB)
  850 IF (NPB.EQ.0) GO TO 860
      WRITE (6,2180)
      WRITE (6,2190) (J,(J,IPNODE(I,J),I=1,3),J=1,NPB)
  860 IF (JNPORT.EQ.0) GO TO 890
      IF (NODSVB.EQ.0) GO TO 870
      WRITE (6,2200)
      WRITE (6,2210) (J,(J, INODB(I,J),I=1,3),J=1,NODSVB)
  870 IF (LEMSVB.EQ.0) GO TO 890
      WRITE (6,2220)
      WRITE (6,2230) (J,(J, IELMB(I,J),I=1,3),J=1,LEMSVB)
C
  890 CONTINUE
      IF (IMODES.EQ.0) GO TO 45
      IF (NPDIS.EQ.0) GO TO 42
      WRITE (6,3040)
      STOP
   42 IF (METHOD.LE.1) GO TO 43
      WRITE (6,3050)
      STOP
   43 IF (IATKEN.EQ.0) GO TO 44
      WRITE (6,3060)
      IATKEN=0
   44 IF (NLSTPD.EQ.0) GO TO 45
      WRITE (6,3070)
      NLSTPD=0
   45 CONTINUE
C
C     MODIFY ANALYSIS CONTROL BLOCKS BASED ON MASTER CONTROL VARIABLES
C
      IF (KLIN.EQ.0) GO TO 7
      IF(IOPE.EQ.3) GO TO 7
      IF (IMODES.EQ.0) GO TO 8
      NSREFB=0
      GO TO 8
    7 NSREFB=0
      NEQITB=0
C
    8 IF (IOUTPT.NE.0) GO TO 6
      NPRIB=1
      IPRIB(1,1)=1
      IPRIB(2,1)=NSTE
      IPRIB(3,1)=1
      NPB=1
      IPNODE(1,1)=1
      IPNODE(2,1)=NUMNP
      IPNODE(3,1)=1
      IDC=1
      IVC=1
      IAC=1
    6 IF (NPB.NE.0) GO TO 9
      IDC=0
      IVC=0
      IAC=0
    9 IPC=IDC + IVC + IAC
C
C
C
C     A L L O C A T E   S T O R A G E   F O R   A R R A Y S
C
C        P E R M A N E N T L Y   S T O R E D   I N - C O R E
C
C
      CALL STORE (NUMNP,NDOF,NEQ,NWK,MA,NEGNL,MAXEST,NBLOCK,ISTOH,0)
C
C
C     R E A D   T I M E   F U N C T I O N   D A T A
C
C
      READ (5,1010) NTFN,NPTM
      IF (IDATWR.LE.1) WRITE (6,2250) NTFN,NPTM
C
      IF (NTFN.EQ.0) GO TO 15
      M2=N1 + NTFN
      M3=M2 + NTFN*NPTM*ITWO
      M4=M3 + NTFN*NPTM*ITWO
      M5=M4 + NTFN*NSTE*ITWO
      M6=M5 + NTFN*ITWO - 1
      CALL SIZE (M6)
C
      CALL TIMFUN (A(M5),A(N1),A(M2),A(M3),A(M4),NTFN,NPTM)
C
C
C     R E A D   N O D A L   P O I N T   D A T A
C
C
   15 MID=0
      IF (NMIDSS .GT. 0) MID=1
      N09=N08 + MID*NUMNP
      N09A=N09 + 3*MID*NUMNP*ITWO
      N1=N09A + 3*MID*NMIDSS*ITWO
      N1A=N1 + NDOF*NUMNP
      N2=N1A + NUMNP
      IF (NSKEWS.EQ.0) N2=N1A
      M3=N2 + NUMNP*ITWO
      M4=M3 + NUMNP*ITWO
      M5=M4 + NUMNP*ITWO - 1
      CALL SIZE (M5)
C
      REWIND 3
      CALL INPUT (A(N06),A(N1A),A(N08),A(N09),A(N09A),A(N1),A(N2),
     1            A(M3),A(M4),IDOF,NDOF,NUMNP,NEQ,NSKEWS,NMIDSS)
C
C
C     R E A D   C O N S T R A I N T   E Q U A T I O N S   D A T A
C
C
      IF (NDISCE.EQ.0) GO TO 29
      CALL CONEQN (A(N1),A(N01),A(N02),A(N03),A(N2),A(M3),NDOF,
     1              NDISCE,NIDM)
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB2
      NN = N1A - 1
      IF (JNPORT.NE.0)
     1  WRITE (LUNODE) RECLB2,(IA(I),I=N1,NN)
C
C***  DATA PORTHOLE (END)
C
C
   29 IF (MODEX.EQ.2) GO TO 30
C
C     WRITE ID ARRAY ONTO TAPE8, IF THIS IS NOT A RESTART JOB
C
      REWIND 8
      NN=N1A - 1
      WRITE (8) (IA(I),I=N1,NN)
C
C
C     SHIFT ID ARRAY FROM N1 TO NEW N09A
C
   30 IF (NMIDSS.EQ.0) GO TO 70
      N09A=N09 + 3*MAXMSS*ITWO
      K=-1
      DO 50 I=1,NDOF
      DO 50 J=1,NUMNP
      K=K + 1
   50 IA(N09A+K)=IA(N1+K)
      N1=N09A
      IF (NSKEWS.EQ.0) GO TO 65
      NN=N1 + NDOF*NUMNP
      DO 60 I=1,NUMNP
   60 IA(NN+I-1)=IA(N1A+I-1)
   65 N1A=N1 + NDOF*NUMNP
      N2=N1A + NUMNP
      IF (NSKEWS.EQ.0) N2=N1A
   70 M3=N2 + NEQ*ITWO
      M4=M3 + NEQ*ITWO
      M5=M4 + NEQ*ITWO
      IF (ISTAT.EQ.0) M5=M3
      M6=M5 + NEQ*ITWO
      IF (IOPE.NE.3) M6=M5
      CALL SIZE (M6)
C
C
C     E S T A B L I S H  C O N C E N T R A T E D   N O D A L
C           M A S S   A N D   D A M P I N G   V E C T O R S
C
C
      REWIND 23
      CALL NODMAS (A(N1),A(N2),A(N2),A(N01),A(N02),A(N03),ISUB,NDOF,
     1             NIDM,IDOF,NUMNP,NEQ,IMASSN,IDAMPN,ISTAT)
C
C
C     R E A D   I N I T I A L   C O N D I T I O N S
C
C
      CALL INITAL (A(N2),A(M5),A(M3),A(M4),A(M4),A(N1),ISUB,NDOF,
     1             IDOF,NEQ,NUMNP)
C
C     R E A D   I N I T I A L   N O D A L   P O I N T
C     T E M P E R A T U R E S
C
      IF (ITP96.NE.2) GO TO 26
      CALL INITEM (A(N2),NUMNP,TSTART)
C
C     REINSTATE NODAL COORDINATES INTO HIGH SPEED STORAGE FROM TAPE
C
   26 NT=3
      REWIND NT
      N3=N2 + NUMNP*ITWO
      N4=N3 + NUMNP*ITWO
      N5=N4 + NUMNP*ITWO
      NN=N3 - 1
      READ (NT) (A(I),I=N2,NN)
      NN=N4 - 1
      READ (NT) (A(I),I=N3,NN)
      NN=N5 - 1
      READ (NT) (A(I),I=N4,NN)
C
      GO TO 999
C
C
C     R E A D   S U B S T R U C T U R E   I N F O R M A T I O N
C
C
  900 CALL SUBINP
C
  999 CONTINUE
C
      RETURN
C
 1000 FORMAT (18A4)
 1001 FORMAT (4I5)
 1002 FORMAT (7I5,2F10.0)
 1003 FORMAT (I5,6I1,I4,3I5,2F10.0,4I5,5X,I5)
 1005 FORMAT (6I5,4F10.0)
 1010 FORMAT (16I5)
 1020 FORMAT (2I5,2F10.0,2I5)
 1100 FORMAT (15I5,5X )
C
 2000 FORMAT (1H1,18A4,///)
 2005 FORMAT(38H M A S T E R  C O N T R O L  C A R D S )
 2010 FORMAT(///,1X,12HCARD NUMBER ,I1)
 2015 FORMAT(/,5X,
     155HNUMBER OF NODAL POINTS  . . . . . . . . . . (NUMNP)   =,I5//5X,
     255HMASTER X-TRANSLATION CODE . . . . . . . . . (IDOF(1)) =,I5//5X,
     355HMASTER Y-TRANSLATION CODE . . . . . . . . . (IDOF(2)) =,I5//5X,
     455HMASTER Z-TRANSLATION CODE . . . . . . . . . (IDOF(3)) =,I5//5X,
     555HMASTER X-ROTATION    CODE . . . . . . . . . (IDOF(4)) =,I5//5X,
     655HMASTER Y-ROTATION    CODE . . . . . . . . . (IDOF(5)) =,I5//5X,
     755HMASTER Z-ROTATION    CODE . . . . . . . . . (IDOF(6)) =,I5//5X,
     855HNUMBER OF LINEAR ELEMENT GROUPS . . . . . . (NEGL)    =,I5//5X,
     955HNUMBER OF NONLINEAR ELEMENT GROUPS  . . . . (NEGNL)   =,I5//5X,
     A55HSOLUTION MODE . . . . . . . . . . . . . . . (MODEX)   =,I5 /5X,
     B55H   EQ.0, DATA CHECK                                        /5X,
     C55H   EQ.1, EXECUTION                                         /5X,
     D55H   EQ.2, RESTART                                           )
 2020 FORMAT (/4X,
     156H NUMBER OF TIME STEPS . . . . . . . . . . . .(NSTE)    =I5//4X,
     256H TIME STEP INCREMENT  . . . . . . . . . . . .(DT)      =E11.4//
     3 4X,
     456H TIME AT SOLUTION START . . . . . . . . . . .(TSTART)  =E11.4//
     5 4X,
     6 55H FLAG FOR WRITING INPUT DATA IN CARD IMAGE AND/OR         /5X,
     7 55H  GENERATED FORM  . . . . . . . . . . . . . (IDATWR)  =I5 /4X,
     8 55H    EQ.0, BOTH CARD IMAGE LISTING AND DETAILED            /4X,
     9 55H          OUTPUT OF INPUT DATA                            /4X,
     A 55H    EQ.1, ONLY DETAILED OUTPUT OF INPUT DATA              /4X,
     B 55H    EQ.2, ONLY A CARD IMAGE LISTING OF INPUT DATA         /4X,
     C 55H    GT.2, NO DETAILED OUTPUT NOR CARD IMAGE               /4X,
     D 55H          LISTING OF INPUT DATA                            )
 2025 FORMAT (/5X,
     155HNUMBER OF INDEPENDENT SUBSTRUCTURES . . . .(NSUBST)   =,I5//5X,
     255HNUMBER OF SKEW (R,S,T) REFERENCE SYSTEMS. .(NSKEWS)   =,I5//5X,
     355HNUMBER OF MID-SURFACE SYSTEMS . . . . . . .(NMIDSS)   =,I5)
 2028 FORMAT (/5X,
     155HRESTART SAVE INTERVAL . . . . . . . . . . .(IRINT)    =,I5//5X,
     255HTEMPERATURE TAPE FLAG . . . . . . . . . . .(ITP96)    =,I5/5X,
     335H   EQ.0, TEMPERATURE TAPE NOT USED,/5X,
     430H   EQ.1, TEMPERATURE TAPE USED/5X,
     531H   EQ.2, TEMPERATURES SPECIFIED/5X,
     631H         VIA INPUT DATA CARDS  //5X,
     7 55HPREPROCESSOR INPUT CONTROL PARAMETER . . . .(INPORT)  =I5 /4X,
     8 55H    EQ.0, NO PREPROCESSOR TAPE USED                       /4X,
     9 56H    EQ.1, NODAL AND ELEMENT INFORMATION READ FROM UNIT59  /4X,
     A 58H    EQ.2, ABOVE INFORMATION AND ID ARRAY READ FROM UNIT59 //5X
     B 55HPORTHOLE PARAMETER  . . . . . . . . . . . . (JNPORT)  =I5 /4X,
     C 55H    EQ.0, PORTHOLE NOT WRITTEN                            /4X,
     D 55H    EQ.1, PORTHOLE WRITTEN                                 //)
 2030 FORMAT (/5X,
     155HNUMBER OF CONCENTRATED LOAD CARDS . . . . . (NLOAD)   =,I5//5X,
     255HNUMBER OF 2/D PRESSURE LOAD SETS. . . . . . (NPR2)    =,I5//5X,
     355HNUMBER OF 3/D PRESSURE LOAD SETS. . . . . . (NPR3)    =,I5//5X,
     455HNUMBER OF BEAM DISTRIBUTED LOAD SETS. . . . (NPBM)    =,I5//5X,
     555HNUMBER OF ISO/BEAM DISTRIBUTED LOAD SETS. . (NPISB)   =,I5//5X,
     655HNUMBER OF PLATE DISTRIBUTED LOAD SETS . . . (NPPL)    =,I5//5X,
     755HNUMBER OF SHELL DISTRIBUTED LOAD SETS . . . (NPSH)    =,I5//5X,
     855HMASS PROPORTIONAL LOADING CODE. . . . . . . (IDGRAV)  =,I5 /5X,
     955H   EQ.0, NO LOADING                                        /5X,
     A55H   EQ.1, LUMPED MASS LOADING                              //5X,
     B55HNUMBER OF PRESCRIBED DISPLACEMENTS. . . . . (NPDIS)   =,I5//5X,
     C55HNUMBER OF NODAL TEMPERATURE CARDS . . . . . (NTEMP)   =,I5//5X,
     D55HNUMBER OF DISPLACEMENT CONSTRAINT EQUATIONS (NDISCE)  =,I5//5X,
     E55HMAX NUMBER OF INDEPENDENT DISPLACEMENTS                    /5X,
     F55H   IN ANY CONSTRAINT EQUATION . . . . . . . (NIDM)    =,I5    )
 2035 FORMAT (/5X,
     155HMASS MATRIX CODE  . . . . . . . . . . . . . (IMASS)   =,I5 /5X,
     255H   EQ.0, NO MASS EFFECTS                                   /5X,
     355H   EQ.1, LUMPED MASS                                       /5X,
     455H   EQ.2, CONSISTENT MASS                                  //5X,
     555HDAMPING MATRIX CODE . . . . . . . . . . . . (IDAMP)   =,I5 /5X,
     655H   EQ.0, NO DAMPING                                        /5X,
     755H   EQ.1, DAMPING INCLUDED                                 //5X,
     855HCONCENTRATED NODAL MASSES CODE. . . . .  . .(IMASSN)  =,I5 /5X,
     955H   EQ.0, NO CONCENTRATED NODAL MASSES                      /5X,
     A55H   EQ.1, CONCENTRATED NODAL MASSES PRESENT                 )
 2040 FORMAT (/5X,
     155HFREQUENCIES SOLUTION CODE . . . . . . . . . . .(IEIG) =,I5 /5X,
     255H   EQ.0, NO FREQUENCIES SOLUTION                           /5X,
     355H   EQ.1, FREQUENCIES AND MODE SHAPES                       /5X,
     455H         ARE DETERMINED                                   //5X,
     555HFLAG INDICATING FREQUENCY SOLUTION TYPE. . . (IESTYP) =,I5 /5X,
     655H   EQ.0, DETERMINANT SEARCH METHOD                         /5X,
     755H   EQ.1, BATHE S  SUBSPACE ITERATION METHOD               //5X,
     855HNUMBER OF EIGENPAIRS TO BE CALCULATED. . . . .(NFREQ) =,I5 /5X,
     955H   EQ.0, DEFAULT SET TO 1 IF IEIG.GT.0                   )
 2042 FORMAT (/5X,
     155HNUMBER OF VECTORS USED FOR SUBSPACE ITERATION . .(NQ) =,I5 /5X,
     255H   EQ.0, SET TO MIN. (2*NFREQ, NFREQ + 8)                  /5X,
     355H   (NOT APPLICABLE IF IESTYP.EQ.0)                        //5X,
     455HNUMBER OF MODE SHAPES TO BE PRINTED. . . . . .(NMODE) =,I5//5X,
     555HINTERMEDIATE PRINT-OUT CONTROL PARAMETER. . . .(IFPR) =,I5 /5X,
     655H   EQ.0, NO PRINTING                                       /5X,
     755H   EQ.1, PRINT                                            //5X,
     855HFLAG INDICATING PRESENCE OF RIGID BODY MODES. .(IRBM) =,I5 /5X,
     955H   EQ.0, NO ZERO FREQUENCIES ARE PRESENT                  //5X,
     A55HRIGID BODY MODE SHIFT APPLIED. . . . . . . . .(RBMSH) =,
     B  E10.3//5X,
     C55HCUT-OFF CIRCULAR FREQUENCY. . . . . . . . . . .(COFQ) =,
     D E10.3 /5X,
     E55H   EQ.0., DEFAULT SET TO 1.D+08                            )
 2045 FORMAT (/5X,
     155HFLAG FOR MODE SUPERPOSITION ANALYSIS . . . (IMODES)   =,I5,/5X,
     255H   EQ.0, STATIC ANALYSIS OR DIRECT TIME INTEGRATION        /5X,
     355H   EQ.1, MODE SUPERPOSITION ANALYSIS PERFORMED            //5X,
     455HTIME INTEGRATION CODE . . . . . . . . . . . (IOPE)    =,I5 /5X,
     555H   EQ.1, WILSON'S  THETA METHOD                        ,/,5X,
     655H   EQ.2, NEWMARK'S  METHOD                             ,/,5X,
     755H   EQ.3, CENTRAL DIFFERENCE METHOD                     ,/,5X)
 2050 FORMAT (5X,
     155HINTEGRATION PARAMETER . . . . . . . . . . . (THETA)   =,F5.2)
 2055 FORMAT (5X,
     155HINTEGRATION PARAMETERS  . . . . . . . . . . (DELTA)   =,F5.2/5X
     255H                                            (ALPHA)   =,F5.2)
 2057 FORMAT (/5X,
     155HNUMBER OF MODES TO BE USED FOR MODE                        /5X,
     255H   SUPERPOSITION ANALYSIS . . . . . . . . .(NMODES)   =,I5//5X,
     355HFLAG FOR INCLUDING MODAL DAMPING EFFECTS . (IMDAMP)   =,I5/ 5X,
     455H   EQ.0, NO MODAL DAMPING EFFECTS                          /5X,
     555H   EQ.1, MODAL DAMPING FACTORS ARE INPUT                   )
 2060 FORMAT (/,4X,
     1 55H NO. OF BLOCKS OF EFFECTIVE STIFFNESS                     /4X,
     256H  REFORMATION TIME STEPS  . . . . . . . . . .(NSREFB)  =I5 /4X,
     3 55H    EQ.0, NO STIFFNESS REFORMATION                       //4X,
     4 55H NO. OF BLOCKS OF EQUILIBRIUM                             /4X,
     556H  ITERATION TIME STEPS  . . . . . . . . . . .(NEQITB)  =I5 /4X,
     6 55H    EQ.0, NO EQUILIBRIUM ITERATION PERFORMED             //5X,
     7 55HEQUILIBRIUM ITERATION METHOD  . . . . . . . (METHOD)  =,I5/4X,
     8 55H    EQ.1, MODIFIED NEWTON ITERATION                       /4X,
     9 55H    EQ.2, BFGS MATRIX UPDATING                           //5X,
     A 55HACCELERATION SCHEME FOR ITERATION . . . . . (IATKEN)  =,I5/4X,
     B 55H    EQ.0, NO ACCELERATION                                 /4X,
     C 55H    EQ.1, AITKEN ACCELERATION                            )
 2061 FORMAT (/5X,
     1 55HMAXIMUM NUMBER OF EQUILIBRIUM                             /5X,
     2 55H  ITERATIONS PERMITTED  . . . . . . . . . . (ITEMAX)  =I5//5X,
     3 55HNO. OF LOAD STEP DIVISIONS                                /5X,
     4 55H  ALLOWED IN DIVERGENCE PROCEDURE . . . . . (NLSTPD)  =I5 /5X,
     4 55H  NLSTPD IS CURRENTLY SET TO ZERO                         /5X,
     4 55H  (DIVERGENCE PROCEDURE IN THIS VERSION NOT ACTIVE)      //5X,
     5 55HDISPLACEMENT CONVERGENCE TOLERANCE  . . . . (DTOL)    =,
     6                                                        E11.4//5X,
     7 55HFORCE        CONVERGENCE TOLERANCE  . . . . (RTOL)    =,
     8                                                        E11.4//5X,
     9 55HLINE SEARCH  CONVERGENCE TOLERANCE  . . . . (STOL)    =,
     2                                                        E11.4//5X,
     H 55HREFERENCE LOAD FOR CONVERGENCE . . . . . . .(RNORM)   =,E11.4)
 2065 FORMAT (/5X,
     155HMASTER CONTROL PARAMETER FOR PRINT-OUT . . . (IOUTPT) =I5 /5X,
     242H   EQ.0, PRINT RESPONSES AT ALL TIME STEPS                  /5X
     340H         AND AT ALL NODES                                  /5X,
     443H   EQ.1, BLOCKS OF PRINT-OUT TIME STEPS AND               /5X,
     540H         NODAL POINTS ARE INPUT LATER                     //5X,
     655HNO. OF BLOCKS OF TIME STEPS FOR NODAL AND ELEMENT         /5X,
     755H ASSOCIATED QUANTITIES PRINT-OUT . . . . . . .(NPRIB) =I5//5X,
     855HNUMBER OF BLOCKS OF NODAL PRINTOUT  . . . . . . (NPB) =,I5//5X,
     955HDISPLACEMENT PRINTOUT CODE  . . . . . . . . . . (IDC) =,I5 /5X,
     A55H   EQ.0, NO PRINTING OF DISPLACEMENTS                      /5X,
     B55H   EQ.1, PRINT DISPLACEMENTS                              //5X,
     C55HVELOCITY PRINTOUT CODE  . . . . . . . . . . . . (IVC) =,I5 /5X,
     D55H   EQ.0, NO PRINTING OF VELOCITIES                         /5X,
     E55H   EQ.1, PRINT VELOCITIES                               //5X,
     F55HACCELERATION PRINTOUT CODE  . . . . . . . . . . (IAC) =,I5 /5X,
     G55H   EQ.0, NO PRINTING OF ACCELERATIONS                      /5X,
     H55H   EQ.1, PRINT ACCELERATIONS                                )
 2066 FORMAT (/5X,
     155HFLAG FOR PRINTING STORAGE INFORMATION. . . . (ISTPRT) =,I5 /5X,
     255H   EQ.0, DO NOT PRINT                                      /5X,
     355H   EQ.1, PRINT                                               )
 2100 FORMAT (/,4X,
     1 55H FLAG FOR SAVING INPUT DATA ON TAPE . . . . (NPUTSV)  =I5 /4X,
     2 55H    EQ.0, WRITE ONLY MAIN HEADER                          /4X,
     3 55H    EQ.1, WRITE ALL INPUT DATA ON PORTHOLE               //4X,
     4 55H NO. OF BLOCKS OF TIME STEPS FOR SAVING                   /4X,
     5 55H  NODAL RESPONSES ON TAPE . . . . . . .  .  (NODSVB)  =I5 /4X,
     6 55H    EQ.0, NO ACTION                                      //4X,
     7 55H NO. OF BLOCKS OF TIME STEPS FOR SAVING                   /4X,
     8 55H  ELEMENT RESPONSES ON TAPE . . . . . . . . (LEMSVB)  =I5 /4X,
     9 55H    EQ.0, NO ACTION                                         /)
 2105 FORMAT (4X,
     1 55H NODE DATA SAVE TAPE NUMBER . . . . . . . . (LUNODE)  =I5//4X,
     2 55H TRUSS/BEAM     TAPE NUMBER . . . . . . . . ( LU1  )  =I5//4X,
     3 55H 2/D CONTINUUM  TAPE NUMBER . . . . . . . . ( LU2  )  =I5//4X,
     4 55H 3/D CONTINUUM AND SHELL TAPE NUMBER. . . . ( LU3  )  =I5//4X,
     5 55H DISPLACEMENT SAVE CODE . . . . . . . . . . (JDC)     =I5 /4X,
     6 55H    EQ.0, NO SAVING OF DISPLACEMENTS                      /4X,
     7 55H    EQ.1, SAVE DISPLACEMENTS ON PORTHOLE                 //4X,
     8 55H VELOCITY SAVE CODE . . . . . . . . . . . . (JVC)     =I5 /4X,
     9 55H    EQ.0, NO SAVING OF VELOCITIES                         /4X,
     A 55H    EQ.1, SAVE VELOCITIES ON PORTHOLE                    //4X,
     B 55H ACCELERATION SAVE CODE . . . . . . . . . . (JAC)     =I5 /4X,
     C 55H    EQ.0, NO SAVING OF ACCELERATIONS                      /4X,
     D 55H    EQ.1, SAVE ACCELERATIONS ON PORTHOLE                //4X,
     E 55H TEMPERATURE SAVE CODE  . . . . . . . . . . (JTC)     =,I5/4X,
     F 55H    EQ.0, NO SAVING OF TEMPERATURES                    /4X,
     G 55H    EQ.1, SAVE TEMPERATURES ON PORTHOLE                //)
 2110 FORMAT (/////40X,14H *  THIS IS A ,A3,A6,2X,A5,A3,11HANALYSIS  * )
 2115 FORMAT (1H1,42H S O L U T I O N   D E T A I L   C A R D S   )
 2120 FORMAT(///5X76HBLOCK DEFINITION CARDS FOR EFFECTIVE STIFFNESS MATR
     1IX REFORMATION TIME STEPS  //5X,
     296H( NOT APPLICABLE FOR LINEAR ANALYSIS, EXPLICIT TIME INTEGRATION
     3 OR MODE SUPERPOSITION ANALYSIS )  )
 2130 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST STEP OF THIS BLOCK  .  .  .  (ISREFB(1,I2,3H))= I5 /7X,
     3 46H LAST  STEP OF THIS BLOCK  .  .  .  (ISREFB(2,I2,3H))= I5 /7X,
     4 46H INCREMENT IN TIME STEP .  .  .  .  (ISREFB(3,I2,3H))= I5 /)
 2140 FORMAT(///5X59HBLOCK DEFINITION CARDS FOR EQUILIBRIUM ITERATION TI
     1ME STEPS   //5X,
     267H( NOT APPLICABLE FOR LINEAR ANALYSIS OR EXPLICIT TIME INTEGRATI
     3ON )  )
 2150 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST STEP OF THIS BLOCK  .  .  .  (IEQITB(1,I2,3H))= I5 /7X,
     3 46H LAST  STEP OF THIS BLOCK  .  .  .  (IEQITB(2,I2,3H))= I5 /7X,
     4 46H INCREMENT IN TIME STEP .  .  .  .  (IEQITB(3,I2,3H))= I5 /)
 2160 FORMAT(///5X47HBLOCK DEFINITION CARDS FOR PRINT-OUT TIME STEPS//5X
     159H( NOT APPLICABLE, IF IOUTPT.EQ.0 ON MASTER CONTROL CARD 8 )  )
 2170 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST STEP OF THIS BLOCK  .  .  .  ( IPRIB(1,I2,3H))= I5 /7X,
     3 46H LAST  STEP OF THIS BLOCK  .  .  .  ( IPRIB(2,I2,3H))= I5 /7X,
     4 46H INCREMENT IN TIME STEP .  .  .  .  ( IPRIB(3,I2,3H))= I5 /)
 2180 FORMAT(///5X49HBLOCK DEFINITION CARDS FOR PRINT-OUT NODAL POINTS//
     15X,59H( NOT APPLICABLE, IF IOUTPT.EQ.0 ON MASTER CONTROL CARD 8 ))
 2190 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST NODE OF THIS BLOCK  .  .  .  (IPNODE(1,I2,3H))= I5 /7X,
     3 46H LAST  NODE OF THIS BLOCK  .  .  .  (IPNODE(2,I2,3H))= I5 /7X,
     4 46H INCREMENT IN NODE NUMBER  .  .  .  (IPNODE(3,I2,3H))= I5 /)
 2200 FORMAT(///5X63HBLOCK DEFINITION CARDS OF TIME STEPS FOR SAVING NOD
     1AL RESPONSES       )
 2210 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST STEP OF THIS BLOCK  .  .  .  ( INODB(1,I2,3H))= I5 /7X,
     C 46H LAST  STEP OF THIS BLOCK  .  .  .  ( INODB(2,I2,3H))= I5 /7X,
     D 46H INCREMENT IN TIME STEP .  .  .  .  ( INODB(3,I2,3H))= I5 /)
 2220 FORMAT(///5X65HBLOCK DEFINITION CARDS OF TIME STEPS FOR SAVING ELE
     1MENT RESPONSES       )
 2230 FORMAT (/,4X,
     1  7H BLOCK ,I2                                               //7X,
     2 46H FIRST STEP OF THIS BLOCK  .  .  .  ( IELMB(1,I2,3H))= I5 /7X,
     3 46H LAST  STEP OF THIS BLOCK  .  .  .  ( IELMB(2,I2,3H))= I5 /7X,
     4 46H INCREMENT IN TIME STEP .  .  .  .  ( IELMB(3,I2,3H))= I5 /)
 2250 FORMAT (1H1,35HT I M E   F U N C T I O N   D A T A   //4X,
     148H NUMBER OF TIME FUNCTIONS               (NTFN) =,I5//4X,
     248H MAX NUMBER OF POINTS IN TIME FUNCTIONS (NPTM) =,I5///)
C
C
 2990 FORMAT (1H1,80H ** STOP **  ERROR IN INPUT OF BLOCK DEFINITIONS OF
     1  NODAL QUANTITIES PRINT-OUT  )
 3000 FORMAT (1H1,21H ** STOP ** ERROR IN ,A8,2X,13H BLOCK INPUT./
     1 14H FIRST STEP OF,I5,34HTH BLOCK IS LESS THAN LAST STEP OF,I5,
     2 9HTH BLOCK.  ///)
 3001 FORMAT(1H1,20H ** STOP ** ERROR IN,A8,2X,44HBLOCK INPUT.FINAL STEP
     1 OF LAST BLOCK INPUT =,I5,18H, LESS THAN NSTE =,I5)
 3004 FORMAT (1H1,21H ** STOP ** ERROR IN ,A8,2X,13H BLOCK INPUT./
     1 14H FIRST STEP OF,I5,36HTH BLOCK IS LARGER THAN LAST STEP OF,I5,
     2 9HTH BLOCK.  ///)
 3002 FORMAT (///46H ""STOP - IMASS MUST BE GT.0 IF CONCENTRATED
     1        / 37H MASSES AND-OR DAMPERS ARE SPECIFIED      )
 3003 FORMAT(///42H ""STOP - IEIG.GT.1 NOT PERMITTED IN THIS
     1       19HVERSION OF ADINA""   )
 3010 FORMAT (///,1H1,100H **STOP** IEIG.GT.0 NOT PERMITTED IF CENTRAL D
     1IFFERENCE METHOD IS TO BE USED FOR TIME INTEGRATION            )
 3012 FORMAT (///,1H1,60H **STOP** IMASS MUST BE EQ. 1 FOR CENTRAL DIFFE
     1RENCE METHOD               )
 3013 FORMAT (///28H *** I N P U T   E R R O R -/
     1        29H DETECTED BY SUBROUTINE ADINI//
     2        5X,9H NSUBST =,I5/5X,7H IEIG =,I5//
     3        35H FREQUENCY ANALYSIS CAN NOT BE DONE/
     4        28H WHEN SUBSTRUCTURES ARE USED//,12H *** S T O P)
 3014 FORMAT (///28H *** I N P U T   E R R O R -/
     1        29H DETECTED BY SUBROUTINE ADINI//
     2        5X,8H ITP96 =,I5/5X,8H NTEMP =,I5//
     3        37H WHEN ITP96.LE.1, NTEMP MUST BE ZERO.//12H *** S T O P)
 3020 FORMAT (///,1H1,75H **STOP** IMASS MUST BE EQ. 1 FOR DYNAMIC ANALY
     1SIS INCLUDING GRAVITY LOADS       )
 3090 FORMAT (///24H I N P U T  E R R O R-     /
     1        29H DETECTED BY SUBROUTINE ADINI    /
     2        38H NEGL,  NEGNL  AND NSUBST ARE ALL ZERO   /
     3        27H P R O G R A M  S T O P S .   /)
 3030 FORMAT(1H1,101H ** STOP **, SUBSTRUCTURES CANNOT BE USED IN A DYNA
     1MIC ANALYSIS, IF CENTRAL DIFFERENCE METHOD IS USED )
 3040 FORMAT (1H1,78H ** STOP **, DISPLACEMENTS CANNOT BE PRESCRIBED IN
     1MODE SUPERPOSITION ANALYSIS  )
 3050 FORMAT (1H1,94H ** STOP **, BFGS EQUILIBRIUM ITERATION METHOD CANN
     1OT BE USED WITH MODE SUPERPOSITION ANALYSIS )
 3060 FORMAT (//85H ** WARNING, AITKEN ACCELERATION CANNOT BE PERFORMED
     1IN A MODE SUPERPOSITION ANALYSIS )
 3070 FORMAT (//,81H ** WARNING, DIVERGENCE PROCEDURE CANNOT BE USED IN
     1A MODE SUPERPOSITION ANALYSIS  )
 3091 FORMAT (1H1,///40H IN THIS VERSION OF ADINA, DISPLACEMENT  ,
     1               37HCONSTRAINT EQUATIONS CAN NOT BE USED     ,
     2               32HWHEN SUBSTRUCTURES ARE PRESENT           ,
     3               28H *** STOP OF SOLUTION ***                )
C
      END
C *CDC* *DECK SUBINP
C *UNI* )FOR,IS N.SUBINP, R.SUBINP
      SUBROUTINE SUBINP
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .      . PROGRAM                                                    .
C .          TO INPUT SUBSTRUCTURE NODAL DATA AND ESTABLISH EQ NUMBERS.
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DPR/ ITWO
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PRCONS/ IPRICS
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /MDFRDM/ IDOF(6)
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /SKEW/ NSKEWS
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
C
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
      DATA RECLB1/8HSUBSTRUC/
C
      READ (5,1000) NS,NTUSE,NEGLS,NUMNPS,NODCON,NODRET,NSMIDS
      DO 5 I=1,6
    5 IDOFS(I)=IDOF(I)
      IF (ISTAT.EQ.0) GO TO 8
      READ (5,1000) IDAMNS,IMASNS
C
    8 IF (IDATWR.GT.1) GO TO 10
      IF (NS.NE.1) WRITE (6,2000)
      WRITE (6,2020) NSUB
      WRITE (6,2050)NS,NTUSE,NEGLS,NUMNPS,NODCON,NODRET,NSMIDS
      IF (ISTAT.EQ.0) GO TO 10
      WRITE (6,2060) IDAMNS,IMASNS
C
   10 IF (NS.EQ.NSUB) GO TO 20
      WRITE (6,3000) NSUB,NS
      STOP
C
   20 IF (NTUSE.EQ.0) NTUSE=1
      NDOFS=6
      DO 30 I=1,6
   30 NDOFS=NDOFS - IDOFS(I)
      NEGNLS=0
      NN=NODRET + NODCON
      IF (NUMNPS.EQ.NN) GO TO 40
      WRITE (6,3050) NS,NODCON,NODRET,NUMNPS
      STOP
C
   40 CONTINUE
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB1
      IF (JNPORT.GE.1 .AND. NPUTSV.GE.1)
     1  WRITE (LUNODE)RECLAB,NS,NTUSE,NEGLS,NUMNPS,NODCON,NODRET,NSMIDS
C
C***  DATA PORTHOLE (END)
C
C
C     R E A D   N O D A L   P O I N T   D A T A
C
C
      N1A=N1 + NDOFS*NUMNPS
      N1B=N1A
      IF (NSKEWS.GT.0) N1B=N1A + NUMNPS
      MID=0
      IF (NSMIDS.GT.0) MID=1
      N1C=N1B + MID*NUMNPS
      N1D=N1C + 3*MID*NUMNPS*ITWO
      N2=N1D + 3*NSMIDS*ITWO
      N3=N2 + NUMNPS*ITWO
      N4=N3 + NUMNPS*ITWO
      N5=N4 + NUMNPS*ITWO
      CALL SIZE (N5)
C
      CALL INPUT (A(N06),A(N1A),A(N1B),A(N1C),A(N1D),A(N1),A(N2),A(N3),
     1            A(N4),IDOFS,NDOFS,NUMNPS,NEQS,NSKEWS,NSMIDS)
C
C     MOVE NODAL COORDINATES, IF MID-SURFACE SYSTEMS ARE USED
C
      IF (NSMIDS.EQ.0) GO TO 60
      NN=N1C + 3*MAXMSS*ITWO
      MM=3*NUMNPS*ITWO
      DO 50 I=1,MM
   50 A(NN+I-1)=A(N2+I-1)
      N2=NN
      N3=N2 + NUMNPS*ITWO
      N4=N3 + NUMNPS*ITWO
      N5=N4 + NUMNPS*ITWO
C
   60 NN=NEQS - NEQC
      KRSIZE=NN*(NN + 1)/2
      IF (KRSIZE.GT.KRSIZM) KRSIZM=KRSIZE
C
C      E S T A B L I S H   C O N C E N T R A T E D   N O D A L
C           M A S S    A N D   D A M P I N G   V E C T O R S
C
      IF (ISTAT.EQ.0 .AND. IDGRAV.EQ.0) GO TO 100
      M5=N5
      NIDMS=0
      CALL NODMAS (A(N1),A(M5),A(M5),A(M5),A(M5),A(M5),ISUB,NDOFS,
     1             NIDMS,IDOFS,NUMNPS,NEQS,IMASNS,IDAMNS,ISTAT)
C
C     R E A D   I N I T I A L   C O N D I T I O N S
C
C
      IF (ISTAT.EQ.0) GO TO 100
      M6=M5 + NEQS*ITWO
      M7=M6 + NEQS*ITWO
      M8=M7 + NEQS*ITWO
      CALL SIZE (M8)
      DO 80 NTU=1,NTUSE
   80 CALL INITAL (A(M5),A(M5),A(M6),A(M7),A(M7),A(N1),ISUB,NDOFS,
     1              IDOFS,NEQS,NUMNPS)
C
  100 RETURN
 1000 FORMAT (7I5)
 2000 FORMAT (1H1)
 2020 FORMAT (25H S U B S T R U C T U R E ,27(1H.),2H =,I5///)
 2050 FORMAT (5X,
     155HSUBSTRUCTURE NUMBER . . . . . . . . . . . .(NSUB)     =,I5//5X,
     255HNUMBER OF TIMES THIS SUBSTRUCTURE IS USED .(NTUSE)    =,I5//5X,
     355HNUMBER OF LINEAR ELEMNT GROUPS . . . . . . (NEGLS)    =,I5//5X,
     455HNUMBER OF NODAL POINTS . . . . . . . . . ..(NUMNPS)   =,I5//5X,
     555HNUMBER OF NODES TO BE CONDENSED . . . . . .(NODCON)   =,I5//5X,
     655HNUMBER OF NODES TO BE RETAINED. . . . . . .(NODRET)   =,I5//5X,
     B55HNUMBER OF SUBSTRUCTURE MID-SURFACE SYSTEMS (NSMIDS)   =,I5//5X)
 2060 FORMAT (5X,
     155HCONCENTRATED NODAL DAMPING CODE. . . . . . .(IDAMNS)  =,I5 /5X,
     255H   EQ.0, NO DAMPING                                        /5X,
     355H   EQ.1, DAMPING INCLUDED                                 //5X,
     455HCONCENTRATED NODAL MASSES CODE. . . . . . . (IMASNS)  =,I5 /5X,
     555H   EQ.0, NO CONCENTRATED NODAL MASSES                      /5X,
     655H   EQ.1, CONCENTRATED NODAL MASSES PRESENT                    )
C
 3000 FORMAT (1H1,37H *** ERROR IN SUBSTRUCTURE DATA INPUT,/
     141H EXPECTING DATA FOR SUBSTRUCTURE NUMBER =,I5/,
     240H INPUT DATA IS FOR SUBSTRUCTURE NUMBER =,I5/)
 3050 FORMAT (37H *** ERROR IN SUBSTRUCTURE DATA INPUT,/
     125H FOR SUBSTUCTURE NUMBER =I5/,88H SUM OF THE NUMBER OF NODES CON
     2DENSED AND RETAINED NODES IS NOT EQUAL TO HTE TOTAL NODES,/,
     38H NODCON=,I5,8H NODRET=,I5,8H NUMNPS=,I5//)
C
      END
C *CDC* *DECK INLIST
C *UNI* )FOR,IS N.INLIST,R.INLIST
      SUBROUTINE INLIST (IDATWR,NCARDS)
C
C     THIS SUBROUTINE PRODUCES A CARD IMAGE LISTING OF THE INPUT FILE
C     (UNIT 5).  NCARDS IS THE NUMBER OF CARDS ALREADY READ BEFORE
C     INLIST IS CALLED
C
      DIMENSION IDATA(20)
      INPUT=5
C
      IF (IDATWR.EQ.1) RETURN
      IF (NCARDS.EQ.0) GO TO 20
      DO 15 I=1,NCARDS
      BACKSPACE INPUT
   15 CONTINUE
C
   20 CONTINUE
      WRITE (6,2000)
      KARD  = 0
      KARDNO = 0
C
   30 READ(5,1000,END=60)  IDATA
   40 KARD=KARD + 1
      KARDNO=KARDNO + 1
      IF (KARDNO.LE.43) GO TO 50
      WRITE (6,2010)
      WRITE (6,2000)
      KARDNO=1
   50 WRITE (6,2020) KARD,IDATA
      GO TO 30
   60 WRITE (6,2010)
      WRITE (6,2030)
      KARD=KARD - NCARDS + 1
C
      DO 70   I=1,KARD
      BACKSPACE INPUT
   70 CONTINUE
C
C
C *CDC*  THE FOLLOWING CARDS ALLOW THE EDITING OF COMMENT CARDS FROM
C *CDC*  THE INPUT STREAM AND ARE INSTALLATION DEPENDENT.
C
C *CDC*  THESE CARDS ARE USED ON THE  CDC  EQUIPMENT BUT MAY BE CHANGED
C *CDC*  FOR THE OPTION TO WORK ON OTHER EQUIPMENT.
C
C
C *CDC*  THIS SUBROUTINE PRODUCES A CARD IMAGE LISTING OF THE INPUT
C *CDC*  DATA ON UNIT 50 IF IDATWR IN THE FIRST DATA SET EQUALS 0 OR 2.
C *CDC*  THE DATA ARE THEN TRANSFERRED TO UNIT 5 WITH ALL THE COMMENT
C *CDC*  CARDS REMOVED FOR SUBSEQUENT EXECUTION.
C
C *CDC*  NCARDS IS THE NUMBER OF CARDS ALREADY READ BEFORE INLIST
C *CDC*  IS CALLED.
C
C *CDC*      DIMENSION IDATA(20)
C
C *CDC*      DATA ICOMNT /4HC***/
C *CDC*      DATA ICBLNK /4HC   /
C
C *CDC*      INPUT=50
C *CDC*      IREAD=5
C *CDC*      KD=0
C
C *CDC*      IF (IDATWR.NE.0 .AND. IDATWR.NE.2) GO TO 100
C
C *CDC*      IF (NCARDS.EQ.0) GO TO 20
C *CDC*      DO 15 I=1,NCARDS
C *CDC*      BACKSPACE INPUT
C *CDC*   15 CONTINUE
C
C *CDC*   20 CONTINUE
C *CDC*      WRITE (6,2000)
C *CDC*      KARD  = 0
C *CDC*      KARDNO = 0
C
C *** ACTIVATE THE FOLLOWING 2 CARDS FOR  CDC  ONLY ***
C
C *CDC*   30 READ (INPUT,1000) IDATA
C *CDC*      IF (EOF(INPUT)) 60,40
C
C *CDC*   40 KARD=KARD + 1
C *CDC*      KARDNO=KARDNO + 1
C *CDC*      IF (KARDNO.LE.43) GO TO 50
C *CDC*      WRITE (6,2010)
C *CDC*      WRITE (6,2000)
C *CDC*      KARDNO=1
C *CDC*   50 IF (IDATA(1).EQ.ICBLNK) IDATA(1)=ICOMNT
C *CDC*      WRITE (6,2020) KARD,IDATA
C *CDC*      IF (IDATA(1).EQ.ICOMNT) GO TO 30
C *CDC*      KD=KD+1
C *CDC*      WRITE (IREAD,1000) IDATA
C *CDC*      GO TO 30
C *CDC*   60 WRITE (6,2010)
C *CDC*      WRITE (6,2030)
C *CDC*      GO TO 160
C
C *** ACTIVATE THE FOLLOWING 2 CARDS FOR  CDC  ONLY ***
C
C *CDC*  100 READ (INPUT,1000) IDATA
C *CDC*      IF (EOF(INPUT)) 161,110
C *CDC*  110 IF (IDATA(1).EQ.ICOMNT .OR. IDATA(1).EQ.ICBLNK) GO TO 100
C *CDC*      KD=KD+1
C *CDC*      WRITE (IREAD,1000) IDATA
C *CDC*      GO TO 100
C
C *CDC*  160 KD=KD-NCARDS
C *CDC*  161 DO 170 I=1,KD
C *CDC*      BACKSPACE IREAD
C *CDC*  170 CONTINUE
C
C
      RETURN
C
 1000 FORMAT (20A4)
 2000 FORMAT(1H1/10X,111HF O L L O W I N G    I S    A    C A R D    I M
     1 A G E    L I S T I N G    O F    T H E    I N P U T    D A T A //
     T58X,26HC O L U M N    N U M B E R,/20X,4HCARD,16X,71H1         2
     X       3         4         5         6         7         8 /
     Y19X,6HNUMBER, 6X,80H1234567890123456789012345678901234567890123456
     Z7890123456789012345678901234567890 /,19X,6(1H-),6X,80(1H-))
 2010 FORMAT (19X,6(1H-),6X,80(1H-),
     T       /20X,4HCARD,16X,71H1         2         3         4
     X5         6        7          8 /19X,6HNUMBER, 6X,80H1234567890123
     Y456789012345678901234567890123456789012345678901234567890123456789
     Z0 /58X,26HC O L U M N    N U M B E R )
 2020 FORMAT (8X,I15,8X,20A4)
 2030 FORMAT(1H0,10X,34(1H*),44H E N D    O F    I N P U T    L I S T I
     1N G ,34(1H*))
C
      END
C *CDC* *DECK OPCOEF
C *UNI* )FOR,IS  N.OPCOEF, R.OPCOEF
      SUBROUTINE OPCOEF (OPVAR)
C
C     CALCULATES COEFFICIENTS OF TIME INTEGRATION OPERATORS
C     FOR THE FOLLOWING METHODS
C     IOPE = 1 .....WILSONS THETA METHOD
C     IOPE = 2 .....NEWMARK METHOD
C     IOPE = 3 .....CENTRAL DIFFERENCE METHOD
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      DIMENSION OPVAR(1)
C
      DATA IOUT/6/
      DATA IOPMAX/3/
C *CDC*      DATA ZERO /1.E-9/
      DATA ZERO /1.D-9/
C *CDC*      DATA THMN /1.39/,THMX /2.01/
      DATA THMN /1.39D0/,THMX /2.01D0/
C
C
      IF (IOPE.LE.IOPMAX) GO TO 99
      WRITE(IOUT,1001)
      STOP
   99 IF (NSTE.EQ.0 .OR. DT.GT.ZERO) GO TO 100
      WRITE(IOUT,1003)
      STOP
  100 CONTINUE
C
      GO TO (101, 111, 121, 131) ,IOPE
C
C     W I L S O N S   T H E T A   M E T H O D
C
  101 IF (OPVAR(1).LE.0.) OPVAR(1)=1.4
      TH=OPVAR(1)
      IF ((TH.GT.THMN).AND.(TH.LT.THMX)) GO TO 102
      WRITE(IOUT,1002)
      STOP
  102 CONTINUE
      DTA=DT*TH
      THSQ=TH*TH
      A0 = 6./(DTA*DTA)
      A1 = 3./DTA
      A2 = 2.*A1
      A3 = 2.
      A4 = 2.
      A5 = .5*DTA
      A6 = A0/TH
      A7 =-A2/TH
      A8 = 1.-3./TH
      A9 = .5*DT
      A10= DT*DT/6.
      GO TO 999
  111 CONTINUE
C
C     N E W M A R K S   M E T H O D
C
      IF (OPVAR(1).LE.0.0) OPVAR(1)=0.5
      IF (OPVAR(2).LE.0.0) OPVAR(2)=0.25*((OPVAR(1) + 0.50)**2)
      DELT=OPVAR(1)
      ALFA=OPVAR(2)
      IF (DELT.LT.0.5) GO TO 113
      IF (DELT.GT.0.55) GO TO 114
      D1=0.5*(DELT+0.5)
      D2=D1*D1
      IF (ALFA.LE.ZERO) GO TO 113
      IF (ALFA.LT.D2) GO TO 115
      IF (ALFA.GT.D1) GO TO 114
      GO TO 116
  113 CONTINUE
      WRITE(IOUT,1002)
      STOP
  114 CONTINUE
      WRITE(IOUT,1004)
      GO TO 116
  115 CONTINUE
      WRITE(IOUT,1005)
  116 CONTINUE
      DEAL=DELT/ALFA
      A0 = 1./(ALFA*DT*DT)
      A1 = DEAL/DT
      A2 = 1./(ALFA*DT)
      A3 = .5/ALFA-1.
      A4 = DEAL-1.
      A5 = DT*(.5*DEAL-1.)
      A6 = A0
      A7 =-A2
      A8 =-A3
      A9 = DT*(1. - DELT)
      A10= DELT*DT
      GO TO 999
  121 CONTINUE
C
C     C E N T R A L  D I F F E R E N C E  M E T H O D
C
      A0=1.0/(DT*DT)
      A1=0.5/DT
      A2=2.0*A0
      A3=1.0/A2
      GO TO 999
C
  131 CONTINUE
  999 CONTINUE
      RETURN
C
 1001 FORMAT(//,10X,42HINTEGRATION METHOD INDICATOR OUT OF RANGE )
 1002 FORMAT(//,10X,41HTIME INTEGRATION PARAMETER NOT ADMISSIBLE)
 1003 FORMAT(//,10X,19HTIME STEP TOO SMALL)
 1004 FORMAT(//,10X,45HTIME INTEGRATION PARAMETER SUSPICIOUS         )
 1005 FORMAT(//,10X,45HCONDITIONALLY STABLE ALGORITHM                )
C
      END
C *CDC* *DECK TIMFUN
C *UNI* )FOR,IS N.TIMFUN,R.TIMFUN
      SUBROUTINE TIMFUN (RGST,IPNT,TIMV,RV,RG,NTFN,NPTM)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   SUBROUTINE TO CALCULATE TIME FUNCTION VALUES AT ALL TIME POINTS .
C .   THE TIME FUNCTION VALUES ARE STORED IN RG                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /CONST/ DT,DTA,ACOEF(21),DTOD,IOPE
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
C
      DIMENSION RG(NTFN,1),TIMV(NPTM,1),RV(NPTM,1),IPNT(1),RGST(1)
C
      DO 100 L=1,NTFN
      READ (5,1000) LL,NPTS
      IF (LL - L) 80,90,80
   80 WRITE (6,2000)
      STOP
C
   90 IF (IDATWR.LE.1) WRITE (6,2002) L,NPTS
      IPNT(LL)=NPTS
      READ  (5,1020) (TIMV(I,LL),RV(I,LL),I=1,NPTS)
      IF (IDATWR.GT.1) GO TO 95
      WRITE (6,2004) (TIMV(I,LL),RV(I,LL),I=1,NPTS)
   95 IF (NPTS.LE.NPTM) GO TO 100
      WRITE (6,2100) L,NPTS,NPTM
      STOP
  100 CONTINUE
C
      NT=13
      IF (NSUBST.GT.0) NT=15
      REWIND NT
      DO 200 L=1,NTFN
      RGST(L)=RV(1,L)
      NPTS=IPNT(L)
      TIME=TSTART + DT
      TIMEP=TSTART + DTA
      I=0
      K=1
  120 I=I + 1
      IF (I-NPTS) 190,130,130
  130 WRITE (6,2010)
      STOP
C
  190 DDR=RV(I+1,L) - RV(I,L)
      DDT=TIMV(I+1,L) - TIMV(I,L)
      IF (DDT) 110,120,150
  110 WRITE (6,2020)
      STOP
  150 SLOPE=DDR/DDT
  180 IF (TIMV(I+1,L)-TIME) 120,140,140
  140 RG(L,K)=RV(I,L) + SLOPE*(TIMEP-TIMV(I,L))
      TIMEP=TIME + DTA
      TIME=TIME + DT
      K=K + 1
      IF (NSTE-K) 195,180,180
  195 WRITE (NT) RGST(L),(RG(L,K),K=1,NSTE),NPTS,
     1           (RV(J,L),TIMV(J,L),J=1,NPTS)
  200 CONTINUE
C
      RETURN
C
 1000 FORMAT (2I5)
 1020 FORMAT (8F10.0)
 2000 FORMAT (43H *** ERROR   TIME FUNCTIONS OUT OF ORDER   )
 2002 FORMAT (///25H TIME FUNCTION NUMBER   =,I5/
     1           25H NUMBER OF TIME POINTS  =,I5//4X,
     2           25H TIME VALUE      FUNCTION/)
 2004 FORMAT (3X,F12.5,2X,E15.7)
 2010 FORMAT (53H *** ERROR   TIME IS LARGER THAN IN THE TIME FUNCTION)
 2020 FORMAT (42H *** ERROR   TIME POINTS ARE OUT OF ORDER  )
 2100 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TIMFUN/
     2        30H WHILE READING TIME FUNCTIONS //
     3     5X,23H TIME FUNCTION NUMBER =,I5/
     4     5X,46H NUMBER OF POINTS IN THIS FUNCTION =,I5,
     5        17H  IS GREATER THAN/
     6     5X,46H THE MAX NUMBER OF POINTS REQUESTED=,I5,
     7        49H  AS SPECIFIED ON THE TIME FUNCTION CONTROL CARD. //
     4        12H *** S T O P)
C
      END
C *CDC* *DECK INPUT
C *UNI* )FOR,IS  N.INPUT,  R.INPUT
      SUBROUTINE INPUT (RSDCOS,NODSYS,MIDSS,FMIDSS,TMIDSS,ID,X,Y,Z,
     1                  IDOF,NDOF,NUMNP,NEQ,NSKEWS,NMIDSS)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .     1. TO READ AND PRINT NODAL POINT INPUT DATA
C .     2. TO GENERATE AND PRINT ALL NODAL DATA
C .     3. TO CALCULATE EQUATION NUMBERS AND STORE THEM IN ID ARRRAY  .
C .                                                                   .
C .           N=ELEMENT NUMBER                                        .
C .           ID=BOUNDARY CONDITION CODES (0=FREE, 1, -1=FIXED,       .
C .                                        -2=CONSTRAINED)            .
C .           X,Y,Z= COORDINATES                                      .
C .           KN= GENERATION CODE, I.E. INCREMENT ON NODAL POINT NO   .
C .           NRST=SKEW SYSTEM SET NUMBER FOR EACH NODE (0 TO NSKEWS) .
C .           IT= INPUT COORDINATE TYPE                               .
C .               EQ.0  RECTANGULAR COORDINATES                       .
C .               EQ.X  CYLINDRICAL COORDINATES (X,R, THETA IN DEG)   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /VAR   / NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1                IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /MIDSYS/ NMIDST,MIDIND,MAXMSS
C
      DIMENSION RSDCOS(9,1),NODSYS(1),ID(NDOF,1),X(1),Y(1),Z(1)
      DIMENSION MIDSS(1),FMIDSS(3,1),TMIDSS(3,1),PARMR(3)
      DIMENSION V1(3),V2(3)
C
      INTEGER IDOF(6),IDT(6),IDTOLD(6),IPRC(4)
C
      DATA RECLB1/8HEQUATONS/, RECLB2/8HNODECORD/
      DATA RECLB3/8HRSDCOS  /,RECLB4/8HNODESYST/,RECLB5/8HNODEMIDS/
      DATA RECLB6/8HNODEFMID/
      DATA IPRC /1H ,1HA,1HB,1HC /
      DATA AHE /4H    /, AHD /4HNRST/
C
C *CDC*      XTOL=1.0E-8
C
      XTOL=1.0D-8
C
      IF (ISUB.GT.0) GO TO 3
      IF (NSKEWS.LT.1) GO TO 3
      CALL RSTSYS (RSDCOS,NSKEWS)
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB3
      IF (JNPORT.NE.0 .AND. NPUTSV.NE.0)
     1  WRITE (LUNODE) RECLAB,NSKEWS,((RSDCOS(K,I),K=1,9),I=1,NSKEWS)
C
C*** DATA PORTHOLE (END)
C
C     READ AND PRINT THE NORMAL VECTORS TABLES
C
    3 IF (NMIDSS.LT.1) GO TO 4
      DO 2 L=1,NUMNP
    2 MIDSS(L)=0
C
      IF (IDATWR.LT.2) WRITE(6,2300)
C
      I=1
      READ(5,1100) N,IDEF,(PARMR(J),J=1,3)
      IF(I.EQ.1 .AND. N.NE.1) GO TO 90
C
C     IF NORMAL VECTOR IS INPUT IN THE -VE Y-DIRECTION, RESET
C     IT TO THE +VE Y-DIRECTION
C
   42 IRESET=0
      IF(IDEF-1)6,6,7
C
    6 IDEF=1
   34 XNORM=0.D0
      DO 35 L=1,3
   35 XNORM=XNORM + PARMR(L)*PARMR(L)
      SQNORM=DSQRT(XNORM)
      DO 8 L=1,3
    8 TMIDSS(L,I)=PARMR(L)/SQNORM
      GO TO 36
C
    7 THT=PARMR(2)*DATAN(1.D0)/45.
      PHI=PARMR(1)*DATAN(1.D0)/45.
      TMIDSS(3,I)=DCOS(THT)
      TMIDSS(2,I)=-DSIN(THT)*DCOS(PHI)
      TMIDSS(1,I)=DSIN(THT)*DSIN(PHI)
      PHI1=PARMR(1)
      THI1=PARMR(2)
   36 CONTINUE
C
      A1=DABS(TMIDSS(1,I))
      A3=DABS(TMIDSS(3,I))
      IF(A3.LT.XTOL .AND. A1.LT.XTOL .AND. TMIDSS(2,I).LT.0.) GO TO 98
      GO TO 69
   98 TMIDSS(2,I)=-TMIDSS(2,I)
      IRESET=1
   69 IF (IDATWR.GT.1) GO TO 9
      IF (IRESET.EQ.1) GO TO 37
      WRITE (6,2310) N,IDEF,(PARMR(J),J=1,3),(TMIDSS(L,I),L=1,3)
      GO TO 9
   37 WRITE (6,2311) N,IDEF,(PARMR(J),J=1,3),(TMIDSS(L,I),L=1,3)
    9 CONTINUE
      I=I+1
   48 IF(I.GT.NMIDSS) GO TO 4
      NOLD=N
      IOLD=IDEF
      READ(5,1100) N,IDEF,(PARMR(J),J=1,3)
      NDIF=N-NOLD
      IF(NDIF.LE.0) GO TO 90
      IF(NDIF.EQ.1) GO TO 42
      IF(IOLD.NE.2) GO TO 218
      IF(IDEF.EQ.2) GO TO 202
  218 WRITE(6,3400)
      STOP
  202 CONTINUE
   44 THI2=PARMR(2)
      PHI2=PARMR(1)
   46 DIF=NDIF
      ANCTH=(THI2-THI1)/DIF
      ANCPH=(PHI2-PHI1)/DIF
      PARMR(1)=PHI1
      PARMR(2)=THI1
      DO 47 II=1,NDIF
      PARMR(1)=PARMR(1)+ANCPH
      PARMR(2)=PARMR(2)+ANCTH
      THT=PARMR(2)*DATAN(1.D0)/45.D0
      PHI=PARMR(1)*DATAN(1.D0)/45.D0
      TMIDSS(3,I)=DCOS(THT)
      TMIDSS(2,I)=-DSIN(THT)*DCOS(PHI)
      TMIDSS(1,I)=DSIN(THT)*DSIN(PHI)
      IRESET=0
      IDEF=2
      A1=DABS(TMIDSS(1,I))
      A3=DABS(TMIDSS(3,I))
      IF(A3.LT.XTOL .AND. A1.LT.XTOL .AND. TMIDSS(2,I).LT.0.) GO TO 97
      GO TO 99
   97 TMIDSS(2,I)=-TMIDSS(2,I)
      IRESET=1
   99 IF(IDATWR.GT.1) GO TO 47
      IF(IRESET.EQ.1) GO TO 210
      WRITE(6,2310) I,IDEF,(PARMR(J),J=1,3),(TMIDSS(L,I),L=1,3)
      GO TO 201
  210 WRITE(6,2311) I,IDEF,(PARMR(J),J=1,3),(TMIDSS(L,I),L=1,3)
  201 I=I+1
   47 CONTINUE
      GO TO 48
   90 WRITE(6,3100)
      STOP
C
C     READ AND PRINT NODAL POINT DATA
C
    4 IF (IDATWR.GT.1) GO TO 5
      IF (ISUB.EQ.0) WRITE (6,2000)
      IF (ISUB.GT.0) WRITE (6,2020)
      WRITE(6,2001)
    5 NOLD=0
      ITOLD=0
      KNOLD=0
      DUM=0.
      ALF=0.
      BTA=0.
      RNEW=0.
      IPR=IPRC(1)
      RAD=DATAN(1.D0)/45.0
C
      IREAD=5
      IF (INPORT.GT.0) IREAD=59
   10 READ(IREAD,1000) IT,N,JPR,(IDT(I),I=1,6),X(N),Y(N),Z(N),KN,
     1                 NRST,MIDS
      IF (N.GT.0 .AND. N.LE.NUMNP) GO TO 25
      WRITE (6,2100) N,NUMNP,NOLD
      STOP
C
   25 IF (IDATWR.LE.1)
     * WRITE (6,2002) IT,N,IDT,X(N),Y(N),Z(N),KN,NRST,MIDS
      IF (N.EQ.1) IPR=JPR
C
      IF (NSKEWS.EQ.0) GO TO 11
      IF (NRST.GE.0 .AND. NRST.LE.NSKEWS) GO TO 11
      WRITE (6,2200) N,NRST,NSKEWS
      STOP
C
   11 IF (IT.EQ.IPRC(1)) GO TO 12
      DUM=Z(N)*RAD
      RNEW=Y(N)
      Z(N)=Y(N)*DSIN(DUM)
      Y(N)=Y(N)*DCOS(DUM)
   12 IF (NMIDSS.LT.1) GO TO 17
      IF (MIDS.LT.1) GO TO 17
      DO 19 L=1,3
   19 FMIDSS(L,N)=TMIDSS(L,MIDS)
      MIDSS(N)=N
   17 II=0
      DO 15 I=1,NDOF
   13 II=II + 1
      IF (II.LE.6) GO TO 14
      WRITE (6,3000)
      STOP
   14 IF (IDOF(II).EQ.1) GO TO 13
   15 ID(I,N)=IDT(II)
      IF (NSKEWS.GT.0) NODSYS(N)=NRST
      IF (NOLD.EQ.0) GO TO 50
      II=0
      DO 20 I=1,NDOF
   16 II=II + 1
      IF (II.LE.6) GO TO 18
      WRITE (6,3000)
      STOP
   18 IF (IDOF(II).EQ.1) GO TO 16
      IF (IDTOLD(II).NE.-1) GO TO 20
      IF (IDT(II).NE.0) GO TO 20
      ID(I,N)=ID(I,NOLD)
      IDT(II)=IDTOLD(II)
   20 CONTINUE
      IF (KNOLD.EQ.0) GO TO 50
C
C     G E N E R A T I O N
C
      NUM=(N-NOLD) / KNOLD
      NUMN=NUM-1
      IF(NUMN.LT.1) GO TO 50
      XNUM=NUM
      DX=(X(N)-X(NOLD))/XNUM
      IF(MIDS.EQ.0 .AND. MIDOLD.EQ.0) GO TO 91
      IF(MIDS.NE.0 .AND. MIDOLD.NE.0) GO TO 91
      WRITE(6,3200)
      STOP
   91 AMIDS=MIDS
      AMOL=MIDOLD
      DM=(AMIDS-AMOL)/XNUM
      IDM=DM
      DMM=IDM
      IF(DM.EQ.DMM) GO TO 92
      WRITE(6,3300) N,NOLD
      STOP
   92 IDM=DM
      IF (IT.EQ.IPRC(1)) GO TO 21
      DR=(RNEW-ROLD)/XNUM
      DT=(DUM-DUMOLD)/XNUM
      DALF=(ALF - ALFOLD)/XNUM
      DBTA=(BTA - BTAOLD)/XNUM
      GO TO 22
   21 DY=(Y(N)-Y(NOLD))/XNUM
      DZ=(Z(N)-Z(NOLD))/XNUM
   22 K=NOLD
      MIDS=MIDOLD
      DO 40 J=1,NUMN
      KK=K
      K=K + KNOLD
      X(K)=X(KK)+DX
      IF (IT.EQ.IPRC(1)) GO TO 26
      ROLD=ROLD+DR
      DUMOLD=DUMOLD+DT
      Y(K)=ROLD*DCOS(DUMOLD)
      Z(K)=ROLD*DSIN(DUMOLD)
      GO TO 94
   26 Y(K)=Y(KK)+DY
      Z(K)=Z(KK)+DZ
   94 MIDS=MIDS+IDM
      IF (NMIDSS.LT.1) GO TO 28
      IF (MIDS.LT.1) GO TO 28
      DO 29 L=1,3
   29 FMIDSS(L,K)=TMIDSS(L,MIDS)
   28 DO 30 I=1,NDOF
      ID(I,K)=ID(I,KK)
   30 CONTINUE
      IF (NSKEWS.GT.0) NODSYS(K)=NODSYS(KK)
      IF (NMIDSS.GT.0 .AND. MIDS.GT.0) MIDSS(K)=K
   40 CONTINUE
C
   50 NOLD=N
      KNOLD=KN
      DUMOLD=DUM
      BTAOLD=BTA
      ALFOLD=ALF
      ROLD=RNEW
      MIDOLD=MIDS
      DO 60 I=1,6
   60 IDTOLD(I)=IDT(I)
      IF(N.NE.NUMNP) GO TO 10
C
      IF (IDATWR.GT.1) GO TO 80
      IF (IPR.EQ.IPRC(2) .OR. IPR.EQ.IPRC(4)) GO TO 80
C
      WRITE(6,2003)
      ARST=AHD
      WRITE (6,2008) ARST
      DO 75 N=1,NUMNP
      I=1
      DO 70 II=1,6
      IDT(II)=IDOF(II)
      IF (IDOF(II).EQ.1) GO TO 70
      IDT(II)=ID(I,N)
      I=I + 1
   70 CONTINUE
      NRST=0
      IF (NSKEWS.GT.0) NRST=NODSYS(N)
      IF (NMIDSS) 72,72,73
   72 WRITE (6,2005) N,IDT,X(N),Y(N),Z(N),NRST
      GO TO 75
   73 IF (MIDSS(N)) 72,72,74
   74 CONTINUE
C
C     CALCULATE DIRECTIONS V1 AND V2 FOR ROTATIONAL D.O.F.
C
      VN1=FMIDSS(1,N)
      VN2=FMIDSS(2,N)
      VN3=FMIDSS(3,N)
      TEMP=DABS(VN2) - 1.0
      TEMP=DABS(TEMP)
      IF (TEMP.GT.XTOL) GO TO 76
C
C     SPECIAL CASE - VN PARALLEL TO  Y-AXIS
C        SET V1 = Z ,  V2 = X
C
      DO 77 LV=1,2
      V1(LV)=0.
   77 V2(LV+1)=0.
      V1(3)=VN2
      V2(1)=VN2
      GO TO 78
C
C     NORMAL CASE - VN NOT PARALLEL TO Y-AXIS
C        SET  V1 = Y CROSS VN ,  V2 = VN CROSS V1
C
   76 DUM=DSQRT(VN1*VN1 + VN3*VN3)
      V1(1)=VN3/DUM
      V1(2)=0.
      V1(3)=-VN1/DUM
      TEMP1=V1(3)*VN2
      TEMP2=-V1(3)*VN1 + V1(1)*VN3
      TEMP3=-V1(1)*VN2
      DUM=DSQRT(TEMP1*TEMP1 + TEMP2*TEMP2 + TEMP3*TEMP3)
      V2(1)=TEMP1/DUM
      V2(2)=TEMP2/DUM
      V2(3)=TEMP3/DUM
   78 WRITE (6,2005) N,IDT,X(N),Y(N),Z(N),NRST,
     1               (V1(LV),LV=1,3),(V2(LV),LV=1,3)
   75 CONTINUE
C
   80 CONTINUE
C
C     COMPACT THE NORMAL VECTOR TABLE (FMIDSS)
C
      IF (NMIDSS.LT.1) GO TO 84
      II=0
      DO 82 I=1,NUMNP
      LL=MIDSS(I)
      IF (LL.EQ.0) GO TO 82
      II=II + 1
      MIDSS(I)=II
      DO 83 L=1,3
   83 FMIDSS(L,II)=FMIDSS(L,I)
   82 CONTINUE
      MAXMSS=II
C
C     NUMBER UNKNOWNS
C
   84 IF (INPORT.EQ.2) GO TO 125
      NEQ=0
      DO 100 N=1,NUMNP
      DO 100 I=1,NDOF
      IDUM=ID(I,N) + 3
      GO TO (100,110,120,110), IDUM
  120 NEQ=NEQ + 1
      ID(I,N)=NEQ
      GO TO 100
  110 ID(I,N)=0
  100 CONTINUE
      GO TO 130
C
C     READ ID ARRAY FROM UNIT 59, INSTEAD OF GENERATING IT
C
  125 DO 126 N=1,NUMNP
      READ (IREAD,1001) (ID(I,N),I=1,NDOF)
  126 CONTINUE
      NEQ=0
      DO 140 N=1,NUMNP
      DO 140 I=1,NDOF
  140 IF (ID(I,N).GT.NEQ) NEQ=ID(I,N)
C
  130 NN=3
      IF (ISUB.EQ.0) GO TO 150
      NN=15
      IF (NSKEWS.EQ.0)
     *  WRITE (NN) ((ID(I,J),I=1,NDOF),J=1,NUMNP)
      IF (NSKEWS.GT.0)
     *  WRITE (NN) ((ID(I,J),I=1,NDOF),J=1,NUMNP),(NODSYS(K),K=1,NUMNP)
      NEQC=0
      DO 145 I=1,NDOF
      DO 145 J=1,NODCON
      II=ID(I,J)
      IF (II.GT.NEQC) NEQC=II
  145 CONTINUE
C
  150 WRITE (NN) (X(I),I=1,NUMNP)
      WRITE (NN) (Y(I),I=1,NUMNP)
      WRITE (NN) (Z(I),I=1,NUMNP)
      IF (ISUB.EQ.0 .AND. NSKEWS.GT.0)
     1    WRITE (NN) (NODSYS(K),K=1,NUMNP)
      IF (IDATWR.GT.1) GO TO 200
      IF (IPR.EQ.IPRC(3) .OR. IPR.EQ.IPRC(4)) GO TO 200
      WRITE (6,2004)
      DO 175 N=1,NUMNP
      I=1
      DO 170 II=1,6
      IDT(II)=0
      IF (IDOF(II).EQ.1) GO TO 170
      IDT(II)=ID(I,N)
      I=I + 1
  170 CONTINUE
  175 WRITE (6,2006) N,(IDT(II),II=1,6)
C
C***  DATA PORTHOLE (START)
C
  200 IF (JNPORT.EQ.0) RETURN
      RECLAB=RECLB1
      WRITE(LUNODE) RECLAB,NDOF,(IDOF(I),I=1,6),((ID(I,J),I=1,NDOF),
     1   J=1,NUMNP),NEQ
      IF (NPUTSV.EQ.0) RETURN
      RECLAB=RECLB2
      WRITE (LUNODE) RECLAB,NUMNP,(X(I),I=1,NUMNP),
     1                            (Y(I),I=1,NUMNP),
     2                            (Z(I),I=1,NUMNP)
      RECLAB = RECLB4
      IF (NSKEWS.GE.1)
     1  WRITE (LUNODE) RECLAB,NUMNP,(NODSYS(I),I=1,NUMNP)
      RECLAB = RECLB5
      IF (NMIDSS.GE.1)
     1  WRITE (LUNODE) RECLAB,NUMNP,(MIDSS(I),I=1,NUMNP)
      RECLAB = RECLB6
      IF (NMIDSS.GE.1)
     1  WRITE (LUNODE) RECLAB,MAXMSS,((FMIDSS(L,I),L=1,3),I=1,MAXMSS)
C
C***  DATA PORTHOLE (END)
C
      RETURN
C
 1000 FORMAT (A1,I4,A1,I4,5I5,3F10.0,3I5)
 1001 FORMAT (6I5)
 1100 FORMAT (2I5,3F10.0)
 2000 FORMAT (1H1,31HN O D A L   P O I N T   D A T A///)
 2020 FORMAT (1H1,57HS U B S T R U C T U R E   N O D A L   P O I N T   D
     1 A T A    ///)
 2001 FORMAT (18H INPUT NODAL DATA //4H IT ,6H  NODE,10X,24HBOUNDARY CON
     1DITION CODES,14X,23HNODAL POINT COORDINATES//,5X,
     214X 1HX 4X 1HY 4X 1HZ 3X 2HXX 3X 2HYY 3X 2HZZ 12X 1HX 12X 1HY 12X
     3        1HZ,8X,2HKN,3X,4HNRST,2X,4HMIDS/,17X,29H( IN COORDINATE SY
     4STEM NRST ),11X,27H( IN COORDINATE SYSTEM IT )  /)
 2002 FORMAT(2X,A1,2X,I5,5X,6I5,3F13.4,5X,I5,I7,I6)
 2003 FORMAT (//21H GENERATED NODAL DATA)
 2004 FORMAT (//17H EQUATION NUMBERS//
     1 35H    N    X    Y    Z   XX   YY   ZZ/
     2 20X,16H  (V1) (V2) (VN)  //)
 2008 FORMAT(/5H NODE 10X 24HBOUNDARY CONDITION CODES 14X 23HNODAL POINT
     1 COORDINATES,20X,24H DIRECTIONS OF V1 AND V2//14X,1HX,4X,1HY,4X,
     2 1HZ,3X,2HXX,3X,2HYY,3X,2HZZ,12X,1HX,12X,1HY,12X,1HZ,3X,A4,
     3 4X,42H(V1,X) (V1,Y) (V1,Z)  (V2,X) (V2,Y) (V2,Z)/12X,
     4 29H( IN COORDINATE SYSTEM NRST ),9X,
     5 30H( IN GLOBAL XYZ COORD SYSTEM )  /)
 2005 FORMAT (I5,5X,6I5,3F13.4,I6,4X,3F7.3,1X,3F7.3)
 2006 FORMAT (7I5)
 2300 FORMAT (1H1,49HT A B L E S   O F   M I D-S U R F A C E   N O D A ,
     1        49H L   P O I N T   N O R M A L   V E C T O R S      ///,
     2       9X,1HN,1X,4HIDEF,5X,8HPARMR(1),5X,8HPARMR(2),
     3       5X,8HPARMR(3),9X,9HCOS(VN,X),4X,9HCOS(VN,Y),4X,
     4       9HCOS(VN,Z)/)
 2310 FORMAT (5X,2I5,3F13.6,5X,3F13.6)
 2311 FORMAT (5X,2I5,3F13.6,5X,3F13.6,4X,20HVN IS RESET TO +VE Y  )
 2100 FORMAT (///24H I N P U T   E R R O R -/
     1        29H DETECTED BY SUBROUTINE INPUT/
     2        32H WHILE READING NODAL COORDINATES//
     3        15H NODE NUMBER N=,I5,
     4        41H IS OUTSIDE THE ALLOWABLE RANGE (1,NUMNP=,I5,2H).//
     5        32H LAST NODE NUMBER READ WAS NOLD=,I5//8H S T O P)
 2200 FORMAT (///24H I N P U T   E R R O R -/
     1        29H DETECTED BY SUBROUTINE INPUT/
     2        32H WHILE READING NODAL COORDINATES//
     3        15H NODE NUMBER N=,I5/
     4        45H SKEW SYSTEM SET NUMBER FOR THIS NODE  NRST =,I5/
     5        42H IS OUTSIDE THE ALLOWABLE RANGE (0,NSKEWS=,I3,2H).//
     6        8H S T O P)
 3000 FORMAT (///48H **STOP, ERROR IN DEGREE OF FREEDOM CALCULATIONS,/,
     1           28H CHECK MASTER CONTROL CARD 1 ,/1X)
 3100 FORMAT(///5X,20HI N P U T  E R R O R/
     A5X,28HDETECTED BY SUBROUTINE INPUT/
     B5X,26HWHILE INPUTING NORMAL SETS/
     C5X,21HFIRST SET MUST BE N=1/
     D5X,45HSETS MUST BE ARRANGED IN ASCENDING ORDER OF N/
     E5X, 8H S T O P)
 3200 FORMAT(///5X,20HI N P U T  E R R O R/
     A5X,28HDETECTED BY SUBROUTINE INPUT/
     B5X,47HCANNOT GENERATE BETWEEN MIDS.EQ.0 AND MIDS.NE.0/
     C5X, 8H S T O P)
 3300 FORMAT(///5X,20HI N P U T  E R R O R/
     A5X,28HDETECTED BY SUBROUTINE INPUT/
     B5X,36HCANNOT GENERATE NORMALS BETWEEN NODS,I5, 3HAND,I5/
     C5X,8H S T O P)
 3400 FORMAT(///5X,20HI N P U T  E R R O R/
     A5X,39HGENERATE NORMALS ONLY WITH IDEF=2.STOP.)
C
      END
C *CDC* *DECK RSTSYS
C *UNI* )FOR,IS N.RSTSYS,R.RSTSYS
      SUBROUTINE RSTSYS (RSDCOS,NSKEWS)
C
C     PROGRAM TO READ, PRINT AND CHECK (A,B,C) ORIENTATION DATA
C     USED TO DESCRIBE SKEW NODE DISPLACEMENTS
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      DIMENSION RSDCOS(9,1),PARMR(6)
      DATA IHED /2H A/,  IHEAD /2H B/
C
      DEGRAD=DATAN(1.D0)/45.
      IF (IDATWR.LE.1) WRITE (6,2000)
C
      DO 400 K=1,NSKEWS
      READ (5,1000) N,IDEF,PARMR
      IF (IDEF.EQ.0) IDEF = 1
      IF (IDATWR.LE.1) WRITE (6,2010) N,IDEF
      IF (IDEF.EQ.2) GO TO 310
C
C     PRINT DIRECTION RATIOS
C
      IF (IDATWR.LE.1) WRITE (6,2020) PARMR
C
C     NORMALISE DIRECTION RATIOS AND STORE THEM
C
      FACR = 0.
      FACS = 0.
C
      DO 200 I=1,3
      FACR = FACR + PARMR(I)  *PARMR(I)
      FACS = FACS + PARMR(I+3)*PARMR(I+3)
  200 CONTINUE
C
      FACR = DSQRT(FACR)
      FACS = DSQRT(FACS)
C
      IF (FACR.EQ.0.) GO TO 220
      IF (FACS.EQ.0.) GO TO 230
      GO TO 250
C
  220 IFAC=IHED
      GO TO 240
  230 IFAC=IHEAD
  240 WRITE (6,2500) N,IFAC
      STOP
C     RSDCOS(9,N) STORES THE FOLLOWING DIRECTION COSINES -
C        COS(A,X), COS(A,Y), COS(A,Z),  COS(B,X), COS(B,Y), COS(B,Z),
C        COS(C,X), COS(C,Y), COS(C,Z),  RESPECTIVELY.
C
  250 DO 300 M=1,3
      RSDCOS(M  ,N) = PARMR(M)  /FACR
      RSDCOS(M+3,N) = PARMR(M+3)/FACS
  300 CONTINUE
C
C     TEST (A,B) DIRECTIONS FOR ORTHOGONALITY
C
      DOT=0.
      DO 305 I=1,3
  305 DOT=DOT + RSDCOS(I,N)*RSDCOS(I+3,N)
      IF (DABS(DOT).LT.1.D-06) GO TO 340
      WRITE (6,2600) N,DOT
      STOP
C
C     PRINT EULER ANGLES
C
C     THE ORDER OF ROTATION IS AS FOLLOWS -
C        1. PHI AROUND X-AXIS
C        2. THETA ABOUT DISPLACED Y-AXIS
C        3. PSI AROUND DISPLACED X-AXIS
C
  310 IF (IDATWR.LE.1) WRITE (6,2030) (PARMR(I),I=1,3)
C
C     COMPUTE THE DIRECTION COSINES FROM EULER ANGLES
C
      DO 315 I=1,3
  315 PARMR(I)=DEGRAD*PARMR(I)
C
      CPHI = DCOS(PARMR(1))
      SPHI = DSIN(PARMR(1))
      CTHT = DCOS(PARMR(2))
      STHT = DSIN(PARMR(2))
      CPSI = DCOS(PARMR(3))
      SPSI = DSIN(PARMR(3))
C
      RSDCOS(1,N) = CTHT
      RSDCOS(2,N) = SPHI*STHT
      RSDCOS(3,N) =-CPHI*STHT
      RSDCOS(4,N) = SPSI*STHT
      RSDCOS(5,N) = CPHI*CPSI - SPHI*SPSI*CTHT
      RSDCOS(6,N) = SPHI*CPSI + CPHI*SPSI*CTHT
C
C     CALCULATE C-AXIS DIRECTION COSINES VIA CROSS PRODUCT
C
  340 RSDCOS(7,N)=RSDCOS(2,N)*RSDCOS(6,N) - RSDCOS(3,N)*RSDCOS(5,N)
      RSDCOS(8,N)=RSDCOS(3,N)*RSDCOS(4,N) - RSDCOS(1,N)*RSDCOS(6,N)
      RSDCOS(9,N)=RSDCOS(1,N)*RSDCOS(5,N) - RSDCOS(2,N)*RSDCOS(4,N)
C
C     PRINT ACTUAL DIRECTION COSINES
C
      IF (IDATWR.LE.1) WRITE (6,2040) (RSDCOS(I,N),I=1,9)
C
  400 CONTINUE
C
      RETURN
C
C     F O R M A T S
C
 1000 FORMAT (2I5,6F10.0)
C
 2000 FORMAT (44H1A - B - C   S K E W   S Y S T E M   D A T A    )
 2010 FORMAT (//
     A 54H SKEW SET NUMBER . . . . . . . . . . . . . (N)       =,I5//
     B 54H SET DEFINITION CODE . . . . . . . . . . . (IDEF)    =,I5 /5X,
     C 54H    EQ.1, BY DIRECTION RATIOS                             /5X,
     D 54H    EQ.2, BY EULER ANGLES                                    )
 2020 FORMAT (//23H INPUT DIRECTION RATIOS,                       //20X,
     A 7H X-AXIS,13X,7H Y-AXIS,13X,7H Z-AXIS,                     // 4X,
     A 7H A-AXIS,3(7X,E13.6)/4X,7H B-AXIS,3(7X,E13.6))
 2030 FORMAT (//34H INPUT EULER ANGLES   (IN DEGREES)//22X,
     A 4H PHI,15X,6H THETA,15X,4H PSI                             //11X,
     B 3(7X,E13.6)                                                     )
 2040 FORMAT (//28H GENERATED DIRECTION COSINES,                  //20X,
     A 7H X-AXIS,13X,7H Y-AXIS,13X,7H Z-AXIS,                     // 4X,
     B 7H A-AXIS,3(7X,E13.6)/4X,7H B-AXIS,3(7X,E13.6)/4X,
     C 7H C-AXIS,3(7X,E13.6)///)
C
 2500 FORMAT (///24H I N P U T   E R R O R -/
     1        30H DETECTED BY SUBROUTINE RSTSYS/
     2        48H WHILE READING SKEW COORDINATE SYSTEM DEFINITION//
     3        27H SKEW SYSTEM SET NUMBER N =,I5/
     4        39H INADMISSIBLE DIRECTION NUMBERS FOR THE,A2,6H-AXIS./5X,
     5        34H (DIRECTION NUMBERS ARE ALL ZERO.)//8H S T O P)
 2600 FORMAT (///24H I N P U T   E R R O R -/
     1        30H DETECTED BY SUBROUTINE RSTSYS/
     2        48H WHILE READING SKEW COORDINATE SYSTEM DEFINITION//
     3        27H SKEW SYSTEM SET NUMBER N =,I5/
     4        32H INADMISSIBLE DIRECTION NUMBERS./5X,
     5        38H A-AXIS AND B-AXIS ARE NOT ORTHOGONAL.  /5X,
     6        14H DOT PRODUCT =,E14.6//8H S T O P)
C
      END
C *CDC* *DECK CONEQN
C *UNI* )FOR,IS N.CONEQN, R.CONEQN
      SUBROUTINE CONEQN (ID,NID,IDI,BETA,NODJ,IDIR,NDOF,NDISCE,NIDM)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   PROGRAM .                                                       .
C .      TO READ IN CONSTRAINT EQUATIONS DATA AND RESET ID ARRAY      .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /MDFRDM/ IDOF(6)
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
C
      DIMENSION ID(NDOF,1),NID(1),IDI(NIDM,1),BETA(NIDM,1),
     1          NODJ(1),IDIR(1)
      DIMENSION BETAG(4),NODL(4)
C
C     READ CONSTRAINED DEGREE OF FREEDOM AND LOCATE IT IN ID ARRAY
C
      IF (IDATWR.LE.1) WRITE (6,2000)
      READ (5,1000) NCEI,NCEG
      NCTOT=NCEI + NCEG
      IF (NCTOT .NE. NDISCE) WRITE (6,3070)
      NCE=0
      IF (NCEI.EQ.0) GO TO 300
      DO 200 K=1,NCEI
C
      READ (5,1000) NCE,NODN,IDIRN,NID(K)
      IF (IDATWR.LE.1) WRITE (6,2010) NCE,NODN,IDIRN,NID(K)
      IF (NCE.EQ.K) GO TO 50
      WRITE (6,3000) K,NCE
      STOP
C
   50 IF (NID(K).LE.NIDM) GO TO 60
      WRITE (6,3010) NCE,NID(K),NIDM
      STOP
C
   60 IDUM=IDIRN
      DO 70 I=1,IDIRN
   70 IF (IDOF(I).EQ.1) IDUM=IDUM - 1
      KK=ID(IDUM,NODN)
      IF (KK.EQ.-2) GO TO 80
      WRITE (6,3020) NODN,IDIRN
      STOP
C
   80 ID (IDUM,NODN)=-NCE
C
      IDUM=NID(K)
      READ (5,1010) (NODJ(J),IDIR(J),BETA(J,K),J=1,IDUM)
      DO 100 I=1,IDUM
  100 IF (BETA(I,K).EQ.0.) BETA(I,K)=1.
      IF (IDATWR.LE.1)
     1 WRITE (6,2020) (NODJ(J),IDIR(J),BETA(J,K),J=1,IDUM)
C
C     ESTABLISH EQUATION NUMBER OF INDEPENDENT DEGREES OF FREEDOM
C
      DO 120 J=1,IDUM
      JJ=NODJ(J)
      IDIRN=IDIR(J)
      II=IDIRN
      DO 110 I=1,IDIRN
  110 IF (IDOF(I).EQ.1) II=II - 1
      IF (ID(II,JJ).GT.0) GO TO 120
      WRITE (6,3030) NCE,JJ,IDIRN
      STOP
  120 IDI(J,K)=ID(II,JJ)
  200 CONTINUE
C
  300 IF (NCEG.EQ.0) GO TO 600
      READ (5,1000) NDCTAB
      IF (NDCTAB.GE.1) GO TO 320
      WRITE (6,3040) NDCTAB
      STOP
C
  320 DO 500 K=1,NDCTAB
      READ (5,1020) NCFIRT,NCLAST,IDIRN,NIDG,(IDIR(J),BETAG(J),J=1,NIDG)
      NJ=NCE+1
      IF (NCFIRT.NE.NJ) WRITE (6,3000) NJ,NCFIRT
C
      MM=4
      IF (NIDG.LE.MM) GO TO 330
      WRITE (6,3010) NCFIRT,NIDG,MM
      STOP
C
  330 IF (NCLAST.GT.NCFIRT) GO TO 335
      WRITE (6,3050)
      STOP
C
  335 READ (5,1050) NCE,NODN,(NODJ(J),J=1,4),KN
      IF (KN.EQ.0) KN=1
      IF (NCE.NE.NCFIRT) WRITE (6,3060) NCE,NCFIRT
      NCEL=NCE
      GO TO 380
C
  340 READ (5,1050) NCEL,NODNL,(NODL(J),J=1,4),KNL
      IF (KNL.EQ.0) KNL=1
      NJ=NCE+1
      IF (NCEL-NJ) 350,360,370
  350 WRITE (6,3000) NJ,NCEL
      STOP
C
  370 NCE=NCE+1
      NODN=NODN+KN
      DO 375 J=1,NIDG
  375 NODJ(J)=NODJ(J)+KN
      GO TO 380
C
  360 NCE=NCEL
      NODN=NODNL
      KN=KNL
      DO 365 J=1,NIDG
  365 NODJ(J)=NODL(J)
C
  380 IDUM=IDIRN
      NID(NCE)=NIDG
      DO 390 I=1,IDIRN
  390 IF (IDOF(I).EQ.1) IDUM=IDUM - 1
      KK=ID(IDUM,NODN)
      IF (KK.EQ.-2) GO TO 395
      WRITE (6,3020) NODN,IDIRN
      STOP
C
  395 ID(IDUM,NODN)=-NCE
C
      IDUM=NIDG
      DO 400 J=1,IDUM
      BETA(J,NCE)=BETAG(J)
  400 IF (BETA(J,NCE).EQ.0.) BETA(J,NCE)=1.
      IF (IDATWR.GT.1) GO TO 410
      WRITE (6,2010) NCE,NODN,IDIRN,NIDG
      WRITE (6,2020) (NODJ(J),IDIR(J),BETA(J,NCE),J=1,IDUM)
C
C     ESTABLISH EQUATION NUMBER OF INDEPENDENT DEGREES OF FREEDOM
C
  410 DO 420 J=1,IDUM
      JJ=NODJ(J)
      IDIRJ=IDIR(J)
      II=IDIRJ
      DO 425 I=1,IDIRJ
  425 IF (IDOF(I).EQ.1) II=II-1
      IF (ID(II,JJ).GT.0) GO TO 420
      WRITE (6,3030) NCE,JJ,IDIRJ
      STOP
  420 IDI(J,NCE)=ID(II,JJ)
C
      NJ=NCE+1
      IF (NCEL-NJ) 430,360,370
  430 IF (NCE.EQ.NCLAST) GO TO 500
      GO TO 340
C
  500 CONTINUE
  600 RETURN
C
 1000 FORMAT (4I5)
 1010 FORMAT (4(2I5,F10.0))
 1020 FORMAT (4I5,4(I5,F10.0))
 1050 FORMAT (7I5)
 2000 FORMAT (1H1,50H C O N S T R A I N T   E Q U A T I O N S   D A T A,
     1//4X,51H    NCE   NODN  IDIRN    NID                        /4X,
     2 4(30H   NODJ   IDIR      BETA      ),/)
 2010 FORMAT (/2X,4(2X,I5))
 2020 FORMAT (4(2X,I5,2X,I5,E14.5,2X)/)
 3000 FORMAT (//48H *** ERROR CONSTRAINT EQUATIONS ARE OUT OF ORDER/
     115H EXPECTING NO =,I4,25H, BUT INPUT EQUATION NO =,I5)
 3010 FORMAT (//19H *** ERROR IN INPUT,/
     116H FOR EQUATION NO,I5,41H NUMBER OF INDEPENDENT DISPLACEMENTS,NID
     2=,I5,46H IS GREATER THAN THE MAXIMUM SPECIFIED ,NIDM =,I5//)
 3020 FORMAT (//19H *** ERROR IN INPUT,/
     112H FOR NODE NO,I5,29H DEGREE OF FREEDOM REFERENCED,I5/,
     284H WAS NOT SPECIFIED AS A DEPENDENT DEGREE OF FREEDOM IN THE NODA
     3L ID ARRAY INPUT DATA)
 3030 FORMAT (24H *** ERROR IN INPUT DATA,/
     116H FOR EQUATION NO,I5,37H THE SPECIFIED INDEPENDENT DOF (NODE=,I4
     2, 7H, IDIR=I4,36H) IS NOT AN ACTIVE DEGREE OF FREEDOM    )
 3040 FORMAT (//19H *** ERROR IN INPUT,/
     154H EXPECTING NDCTAB GREATER THAN ZERO, BUT INPUT NDCTAB=,I5)
 3050 FORMAT (//19H *** ERROR IN INPUT,/
     127H NCLAST MUST BE .GE. NCFIRT)
 3060 FORMAT (//19H *** ERROR IN INPUT,/
     149H EXPECTING NCE EQUAL TO NCFIRT, BUT INPUT IS NCE=,I5,
     212H AND NCFIRT=,I5)
 3070 FORMAT (//19H *** ERROR IN INPUT,/
     143H EXPECTING NCEI + NCEG=NDISCE, BUT INPUT IS,/,
     26H NCEI=,I5,6H NCEG=,I5,12H AND NCISCE=,I5)
C
      END
C *CDC* *DECK NODMAS
C *UNI* )FOR,IS  N.NODMAS, R.NODMAS
      SUBROUTINE NODMAS (ID,XMN,XSI,NID,IDI,BETA,ISUB,NDOF,NIDM,
     1                   IDOF,NUMNP,NEQ,IMASSN,IDAMPN,ISTAT)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   READS THE NODAL CONCENTRATED NODAL MASSES AND DAMPERS           .
C .                                                                   .
C .   FINDS NODAL MASS VECTOR OR NODAL DAMPING VECTOR  ( XMN )        .
C .                                                                   .
C .   WRITES NODAL MASS AND DAMPING VECTORS ON TAPE11                 .
C .   (THESE VECTORS ARE STORED TEMPORARILY UNTIL USE IN ASSEM)       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /SKEW/ NSKEWS
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PRCONS/ IPRICS
      DIMENSION ID(NDOF,1),XMN(1),NID(1),IDI(NIDM,1),BETA(NIDM,1),
     1          XSI(1),XMASS(6),XDAMP(6),IDT(6),OXMASS(6),OXDAMP(6),
     2          DX(6),IDOF(6)
C
C     N O D A L   M A S S E S
C
C
      II=1
      DO 10 I=1,6
      JTEST=IDOF(I)
      IF (JTEST.EQ.1) GO TO 10
      IDT(II)=I
      II=II + 1
   10 CONTINUE
C
      DO 80 J=1,NEQ
   80 XMN(J)=0.
      IF (IMASSN.EQ.0)GO TO 200
      IF (IDATWR.GT.1) GO TO 82
      IF (NSKEWS.LE.0) WRITE (6,2000)
      IF (NSKEWS.GT.0) WRITE (6,2100)
   82 CONTINUE
C
C     READ  IN  NODAL  MASSES
C
      KNOLD=0
C
   20 READ (5,1000) N,KN,(XMASS(I),I=1,6),IDEBUG
C
      IF (KNOLD.EQ.0 .AND. IDATWR.LE.1) WRITE (6,2001) N,KN,(XMASS(I),
     1I=1,6)
C
      IF (N.LE.NUMNP .AND. N.GE.1) GO TO 30
      WRITE (6,1020) N, NUMNP
      STOP
C
   30 DO 90 J=1,NDOF
      JM=IDT(J)
      JJ=ID(J,N)
      IF (JJ) 87,90,89
C
   87 NCE=-JJ
      ND=NID(NCE)
      DO 88 I=1,ND
      JJ=IDI(I,NCE)
      FAC=BETA(I,NCE)
   88 XMN(JJ)=XMN(JJ) + FAC*XMASS(JM)*FAC
      GO TO 90
C
   89 XMN(JJ)=XMN(JJ) + XMASS(JM)
   90 CONTINUE
C
      IF (KNOLD.EQ.0) GO TO 170
C
C     GENERATION  OF  NODAL  MASSES
C
      NUM=(N - NOLD)/KNOLD
      NUMN=NUM - 1
      IF (NUMN.LT.1) GO TO 170
      XNUM=NUM
C
      DO 100 I=1,6
  100 DX(I)=(XMASS(I) - OXMASS(I))/XNUM
C
      K=NOLD
C
C
      DO 160 KJ=1,NUMN
      K=K + KNOLD
C
      DO 110 I=1,6
      XMASS(I)=OXMASS(I) + DX(I)
  110 OXMASS(I) = XMASS(I)
C
      IF (IDATWR.LE.1) WRITE (6,2001) K,KNOLD,(XMASS(I),I=1,6)
C
      DO 150 J=1,NDOF
      JM=IDT(J)
      JJ = ID(J,K)
      IF (JJ) 120, 150, 140
C
  120 NCE = -JJ
      ND=NID(NCE)
      DO 130 I=1,ND
      JJ=IDI(I,NCE)
      FAC=BETA(I,NCE)
  130 XMN(JJ)=XMN(JJ) + FAC*XMASS(JM)*FAC
      GO TO 150
C
  140 XMN(JJ)=XMN(JJ) + XMASS(JM)
C
  150 CONTINUE
  160 CONTINUE
      DO 165 I=1,6
  165 XMASS(I)=XMASS(I) + DX(I)
C
C
  170 IF (KNOLD.NE.0 .AND. IDATWR.LE.1) WRITE (6,2001) N,KN,(XMASS(I),
     1I=1,6)
      KNOLD=KN
      NOLD=N
      IF (KNOLD.EQ.0) GO TO 190
      DO 180 I=1,6
  180 OXMASS(I)=XMASS(I)
  190 CONTINUE
C
      IF (N.LT.NUMNP) GO TO 20
C
C     STORE NODAL MASS VECTOR ON TAPE 23
C
  200 WRITE (23) (XMN(I),I=1,NEQ)
      IF (IDEBUG.EQ.1) WRITE (6,3000) (XMN(I),I=1,NEQ)
C
C     N O D A L   D A M P E R S
C
      DO 210 I=1,NEQ
  210 XMN(I)=0.0
      IF (IDAMPN.EQ.0) GO TO 320
      IF (IDATWR.GT.1) GO TO 182
      IF (NSKEWS.LE.0) WRITE (6,2010)
      IF (NSKEWS.GT.0) WRITE (6,2200)
  182 CONTINUE
C
C     READ  IN  NODAL  DAMPERS
C
      KNOLD=0
C
  220 READ (5,1000) N,KN,(XDAMP(I),I=1,6),IDEBUG
C
      IF (KNOLD.EQ.0 .AND. IDATWR.LE.1) WRITE (6,2001) N,KN,(XDAMP(I),
     1I=1,6)
C
      IF (N.LE.NUMNP .AND. N.GE.1) GO TO 230
      WRITE (6,1030) N, NUMNP
      STOP
C
  230 DO 290 J=1,NDOF
      JM=IDT(J)
      JJ=ID(J,N)
      IF (JJ) 287,290,289
C
  287 NCE=-JJ
      ND=NID(NCE)
      DO 288 I=1,ND
      JJ=IDI(I,NCE)
      FAC=BETA(I,NCE)
  288 XMN(JJ)=XMN(JJ) + FAC*XDAMP(JM)*FAC
      GO TO 290
C
  289 XMN(JJ)=XMN(JJ) + XDAMP(JM)
  290 CONTINUE
C
      IF (KNOLD.EQ.0) GO TO 470
C
C     GENERATION  OF  NODAL  DAMPERS
C
      NUM=(N - NOLD)/KNOLD
      NUMN=NUM - 1
      IF (NUMN.LT.1)GO TO 470
      XNUM=NUM
C
      DO 400 I=1,6
  400 DX(I)=(XDAMP(I) - OXDAMP(I))/XNUM
C
      K=NOLD
C
C
      DO 460 KJ=1,NUMN
      K=K + KNOLD
C
      DO 410 I=1,6
      XDAMP(I)=OXDAMP(I) + DX(I)
  410 OXDAMP(I)=XDAMP(I)
C
      IF (IDATWR.LE.1) WRITE (6,2001) K,KNOLD,(XDAMP(I),I=1,6)
C
      DO 450 J=1,NDOF
      JM=IDT(J)
      JJ=ID(J,K)
      IF (JJ) 420, 450, 440
C
  420 NCE= -JJ
      ND=NID(NCE)
      DO 430 I=1,ND
      JJ=IDI(I,NCE)
      FAC=BETA(I,NCE)
  430 XMN(JJ)=XMN(JJ) + FAC*XDAMP(JM)*FAC
      GO TO 450
C
  440 XMN(JJ)=XMN(JJ) + XDAMP(JM)
C
  450 CONTINUE
  460 CONTINUE
C
      DO 465 I=1,6
  465 XDAMP(I)=XDAMP(I) + DX(I)
C
  470 IF (KNOLD.NE.0 .AND. IDATWR.LE.1) WRITE (6,2001) N,KN,(XDAMP(I),
     1I=1,6)
      KNOLD=KN
      NOLD=N
      IF (KNOLD.EQ.0) GO TO 490
C
      DO 480 I=1,6
  480 OXDAMP(I)=XDAMP(I)
C
  490 CONTINUE
C
      IF (N.LT.NUMNP) GO TO 220
C
C     STORE NODAL DAMPER VECTOR ON TAPE 23
C
  320 WRITE (23) (XMN(I),I=1,NEQ)
      IF (IDEBUG.EQ.1) WRITE (6,3010) (XMN(I),I=1,NEQ)
      IF (ISTAT.EQ.0) IDAMPN=0
C
C
C     M O D A L   D A M P I N G   F A C T O R S
C
C
      IF (IMODES.EQ.0) RETURN
      DO 330 I=1,NMODES
  330 XSI(I)=0.
      IF (IMDAMP.EQ.0) GO TO 340
C
      READ (5,1010) (XSI(I),I=1,NMODES)
      IF (IDATWR.GT.1) GO TO 340
      WRITE (6,2020)
      WRITE (6,2030) (I,XSI(I),I=1,NMODES)
C
  340 REWIND 7
      WRITE (7) (XSI(I),I=1,NMODES)
C
      RETURN
C
 1000 FORMAT (2I5,6F10.0,I5)
 1010 FORMAT (8F10.0)
 1020 FORMAT (///24H I N P U T  E R R O R -  /
     1        30H DETECTED BY SUBROUTINE NODMAS/
     2        30H WHILE READING NODAL MASS DATA//
     3        15H NODE NUMBER N=,I5,
     4        41H IS OUTSIDE THE ALLOWABLE RANGE (1,NUMNP=,I5,2H).//
     5        27H P R O G R A M  S T O P S .)
 1030 FORMAT (///24H I N P U T  E R R O R -  /
     1        30H DETECTED BY SUBROUTINE NODMAS/
     2        33H WHILE READING NODAL DAMPING DATA//
     3        15H NODE NUMBER N=,I5,
     4        41H IS OUTSIDE THE ALLOWABLE RANGE (1,NUMNP=,I5,2H).//
     5        27H P R O G R A M  S T O P S .)
 2000 FORMAT (1H1,31H N O D A L   M A S S   D A T A   ///
     1        ,7H   NODE,6H   KN ,11H     X-MASS,11H     Y-MASS,
     2        11H     Z-MASS,11H    XX-MASS,11H    YY-MASS,
     3        11H    ZZ-MASS//)
 2001 FORMAT ( I7,I5,2X,6E11.3/)
 2010 FORMAT (1H1,37H N O D A L   D A M P E R S   D A T A        ///
     1        ,7H   NODE,6H   KN ,11H   X-DAMPER,11H   Y-DAMPER,
     2        11H   Z-DAMPER,11H  XX-DAMPER,11H  YY-DAMPER,
     3        11H  ZZ-DAMPER//)
 2020 FORMAT (1H1,41HM O D A L   D A M P I N G   F A C T O R S  ///,
     1        7H   MODE,17H   DAMPING FACTOR  //)
 2030 FORMAT (2X,I5,5X,E12.4/)
 2100 FORMAT (1H1,30H N O D A L   M A S S   D A T A///
     A        40H CONCENTRATED NODAL MASSES ARE ASSUMED  /
     B 56H TO BE GIVEN IN THE SKEW COORDINATE SYSTEM OF EACH NODE.///
     C        7H   NODE,6H   KN ,5X,6HR-MASS,5X,6HS-MASS,5X,6HT-MASS,
     D        4X,7HRR-MASS,4X,7HSS-MASS,4X,7HTT-MASS//)
 2200 FORMAT (1H1,36H N O D A L   D A M P E R S   D A T A///
     A        40H CONCENTRATED NODAL DAMPERS ARE ASSUMED /
     B 56H TO BE GIVEN IN THE SKEW COORDINATE SYSTEM OF EACH NODE.///
     C        7H   NODE,6H   KN ,11H   R-DAMPER,11H   S-DAMPER,
     D        11H   T-DAMPER,11H  RR-DAMPER,11H  SS-DAMPER,
     E        11H  TT-DAMPER//)
 3000 FORMAT (//18H NODAL MASS VECTOR,/,(8E15.5/))
 3010 FORMAT (//20H NODAL DAMPER VECTOR,/,(8E15.5/))
C
C
      END
C *CDC* *DECK INITAL
C *UNI* )FOR,IS  N.INITAL, R.INITAL
      SUBROUTINE INITAL (DISP,DISPM,VEL,ACC,DUM,ID,ISUB,NDOF,
     1                   IDOF,NEQ,NUMNP)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      TO INITIALIZE DISPLACEMENTS, VELOCITIES AND ACCELERATIONS    .
C .                                                                   .
C .        DISP = DISPLACEMENTS                                       .
C .        VEL  = VELOCITIES                                          .
C .        ACC  = ACCELERATIONS                                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PRCONS/ IPRICS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /TICON/ IPRIT
C
      DIMENSION DISP(1),VEL(1),ACC(1),DUM(1),ID(NDOF,1),DISPM(1),
     1           IDT(6),VAR(6),OLDVAR(6),DX(6),IDOF(6)
C
      IF (ISUB.GT.0) GO TO 40
      READ (5,1000) ICON,IPRIC,ICONT,IPRIT
      IF (ITP96.NE.2) GO TO 20
      IF (ICONT.NE.0) GO TO 20
      WRITE (6,2100) ITP96,ICONT
      STOP
C
   20 IF (ITP96.EQ.0) IPRIT=0
      IF (IDATWR.LE.1) WRITE (6,2000) ICON,IPRIC,ICONT,IPRIT
      GO TO 50
   40 READ (5,1000) ICON
      IF (IDATWR.LE.1) WRITE (6,2050) ICON
   50 IF (MODEX.EQ.2) RETURN
C
      IF (ICON.GT.0) GO TO 115
C
C     ZERO INITIAL CONDITIONS ARE GENERATED
C
C
      DO 100 I=1,NEQ
  100 DISP(I)=0.
      IF (ISTAT.EQ.0) GO TO 230
      DO 110 I=1,NEQ
      VEL(I)=0.
  110 ACC(I)=0.
      GO TO 200
C
C     READ IN INITIAL VALUES, VERIFY, AND
C     PRINT OR GENERATE AS NECESSARY
C
  115 II=1
      DO 30 I=1,6
      JTEST=IDOF(I)
      IF (JTEST.EQ.1) GO TO 30
      IDT(II)=I
      II=II + 1
   30 CONTINUE
C
      ICNC=-1
C
  120 KNOLD=0
C
      IF (IDATWR.GT.1) GO TO 160
C
      IF(ICNC) 130,140,150
C
  130 WRITE (6,1020)
      GO TO 160
C
  140 WRITE (6,1030)
      GO TO 160
C
  150 WRITE (6,1040)
C
C     DUM IS A DUMMY ARRAY OCCUPYING THE SAME
C     STORAGE LOCATIONS AS THE ARRAY ACC
C
  160 DO 165 I=1,NEQ
  165 DUM(I)=0.0
C
C
  170 READ (5,1010) N,KN,(VAR(I),I=1,6)
C
      IF (IDATWR.GT.1) GO TO 180
C
C     PRINT INITIAL VALUES
C
      WRITE (6,1050) N,KN,(VAR(I),I=1,6)
C
  180 IF (N.LE.NUMNP .AND. N.GE.1) GO TO 400
      WRITE (6,1060) N,NUMNP
      STOP
C
  400 DO 420 J=1,NDOF
      JM=IDT(J)
      JJ=ID(J,N)
      IF (JJ) 420,420,410
  410 DUM(JJ)=DUM(JJ) + VAR(JM)
  420 CONTINUE
C
      IF (KNOLD.EQ.0) GO TO 500
C
C     GENERATION OF INTERMEDIATE VALUES
C
      NUM=(N - NOLD)/KNOLD
      NUMN= NUM - 1
      IF (NUMN.LT.1) GO TO 500
      XNUM=NUM
C
      DO 430 I=1,6
  430 DX(I)=(VAR(I) - OLDVAR(I))/XNUM
C
      K=NOLD
C
C
      DO 470 KJ=1,NUMN
      K=K + KNOLD
C
      DO 440 I=1,6
      VAR(I)=OLDVAR(I) + DX(I)
  440 OLDVAR(I)=VAR(I)
C
      DO 460 J=1,NDOF
      JM=IDT(J)
      JJ=ID(J,K)
      IF (JJ) 460,460,450
  450 DUM(JJ)=DUM(JJ) + VAR(JM)
  460 CONTINUE
C
  470 CONTINUE
C
      DO 480 I=1,6
  480 VAR(I)=VAR(I) + DX(I)
C
  500 KNOLD=KN
      NOLD=N
      IF (KNOLD.EQ.0) GO TO 520
C
      DO 510 I=1,6
  510 OLDVAR(I)=VAR(I)
C
  520 CONTINUE
C
      IF (N.LT.NUMNP) GO TO 170
C
C
      IF(ICNC) 540,550,560
C
C     TRANSFER INITIAL DISPLACEMENTS FROM DUM TO DISP
C
  540 DO 545 I=1,NEQ
  545 DISP(I)=DUM(I)
      IF (ISTAT.EQ.0) GO TO 230
      GO TO 560
C
C     TRANSFER INITIAL VELOCITIES FROM DUM TO VEL
C
  550 DO 555 I=1,NEQ
  555 VEL(I)=DUM(I)
C
C     A TRANSFER HERE IS NOT NECESSARY SINCE
C     ACC AND DUM OCCUPY THE SAME STORAGE LOCATIONS
C
  560 ICNC=ICNC + 1
C
      IF(ICNC.LE.1) GO TO 120
C
C
  200 IF (IOPE.NE.3) GO TO 230
C
C     FOR EXPLICIT TIME INTEGRATION SCHEME CALCULATE DISPLACEMENTS
C     AT TIME=TSTART + DT AND STORE ON TAPE8
C
      DO 220 I=1,NEQ
  220 DISPM(I)=DISP(I) + DT*VEL(I) + A3*ACC(I)
      WRITE (8) (DISPM(I),I=1,NEQ)
C
  230 WRITE (8) (DISP(I),I=1,NEQ)
      IF (ISTAT.EQ.0) RETURN
      WRITE (8) (VEL(I),I=1,NEQ)
      WRITE(8) (ACC(I),I=1,NEQ)
C
  300 RETURN
C
 1000 FORMAT (16I5)
 1010 FORMAT (2I5,6F10.0)
 1020 FORMAT (///23H INITIAL DISPLACEMENTS      ///
     1        ,7H   NODE,6H   KN ,11H     X-DISP,11H     Y-DISP,
     2        11H     Z-DISP,11H     X-ROTN,11H     Y-ROTN,
     3        11H     Z-ROTN//)
 1030 FORMAT (///20H INITIAL VELOCITIES    ///
     1        ,7H   NODE,6H   KN ,11H      X-VEL,11H      Y-VEL,
     2        11H      Z-VEL,11H     X-ROTN,11H     Y-ROTN,
     3        11H     Z-ROTN//)
 1040 FORMAT (///23H INITIAL ACCELERATIONS   ///
     1        ,7H   NODE,6H   KN ,11H     X-ACCN,11H     Y-ACCN
     2        11H     Z-ACCN,11H     X-ROTN,11H     Y-ROTN,
     3        11H     Z-ROTN//)
 1050 FORMAT (I7,I5,2X,6E11.3/)
 1060 FORMAT( ///24H I N P U T  E R R O R -  /
     1        30H DETECTED BY SUBROUTINE INITAL  /
     2        29H WHILE READING INITIAL VALUES  //
     3        16H NODE NUMBER N =,I5,
     4        41H IS OUTSIDE THE ALLOWABLE RANGE (1,NUMNP=,I5,2H).//
     5        27H P R O G R A M  S T O P S .  )
 2000 FORMAT (1H1,36H I N I T I A L  C O N D I T I O N S     ///
     1  5X,51HINITIAL CONDITIONS CODE                    (ICON) =,I5/4X
     2            42H    EQ.0, ZERO INITIAL CONDITIONS              /4X,
     3            42H    EQ.1, INITIAL CONDITIONS ARE READ       /10X,
     4            34H    (BUT RESTART OVER-RIDES ICON)            //
     5  5X,51HINITIAL CONDITIONS PRINT-OUT CODE         (IPRIC) =,I5/4X
     6            42H    EQ.0, DO NOT PRINT                      /4X,
     A            15H    EQ.1, PRINT//
     B 5X,51HINITIAL TEMPERATURES CODE                 (ICONT) =,I5/
     C 8X,50HEQ.0, INITIAL TEMPERATURES ARE NOT                /
     D 8X,21H      READ FROM INPUT/
     E 8X,50HEQ.1, INITIAL TEMPERATURES ARE READ FROM INPUT    //
     E 5X,51HINITIAL TEMPERATURES PRINT-OUT CODE       (IPRIT) =,I5/
     F 8X,39HEQ.0, DO NOT PRINT INITIAL TEMPERATURES/
     G 8X,39HEQ.1, PRINT INITIAL TEMPERATURES       /)
 2050 FORMAT (1H1,36H I N I T I A L  C O N D I T I O N S             ///
     1  5X,51HINITIAL CONDITIONS CODE                    (ICON) =,I5/4X
     2            42H    EQ.0, ZERO INITIAL CONDITIONS              /4X,
     3            42H    EQ.1, INITIAL CONDITIONS ARE READ          /10X
     4            34H    (BUT RESTART OVER-RIDES ICON)               //)
 2100 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUROUTINE INITAL /
     2        46H WHILE READING INITIAL CONDITIONS CONTROL CARD//
     3        5X,8H ITP96 =,I5/5X,8H ICONT =,I5//
     4        5X,48H WHEN TEMPERATURES ARE SPECIFIED VIA INPUT CARDS,
     5        19H (I.E. ITP96.EQ.2),/
     6 5X,50H INITIAL TEMPERATURES MUST BE READ IN THIS SECTION,
     7        27H (I.E. ICONT MUST BE GT.0).//12H *** S T O P )
C
      END
C *CDC* *DECK INITEM
C *UNI* )FOR,IS N.INITEM,R.INITEM
      SUBROUTINE INITEM (TEMP,NUMNP,TSTART)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   PROGRAM                                                         .
C .      . TO READ IN INITIAL TEMPERATURES (I.E. AT TIME TSTART)      .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
C
      DIMENSION TEMP(1)
C
      DATA ITT /56/
C
      DO 10 I=1,NUMNP
   10 TEMP(I)=0.
      IF (IDATWR.LE.1) WRITE (6,2000)
      ICARD=1
      READ (5,1000) NOLD,TNOLD,KNOLD
      IF (IDATWR.LE.1) WRITE (6,2050) ICARD,NOLD,TNOLD,KNOLD
      IF (NOLD.GT.0 .AND. NOLD.LE.NUMNP) GO TO 25
      WRITE (6,2100) NOLD,TNOLD,KNOLD,NUMNP
      STOP
   25 TEMP(NOLD)=TNOLD
C
   30 ICARD=ICARD+1
      READ (5,1000) N,TN,KN
      IF (IDATWR.LE.1) WRITE (6,2050) ICARD,N,TN,KN
      IF (N.GT.0 .AND. N.LE.NUMNP) GO TO 50
      WRITE (6,2100) N,TN,KN,NUMNP
      STOP
C
   50 TEMP(N)=TN
      IF (KNOLD.EQ.0) GO TO 75
C
C     G E N E R A T I O N
C
      NUM=(N-NOLD)/KNOLD
      NUMN=NUM-1
      IF (NUMN.LT.1) GO TO 75
      DTEMP=(TEMP(N)-TEMP(NOLD))/DBLE(FLOAT(NUM))
      KJ=NOLD
      DO 60 J=1,NUMN
      KI=KJ
      KJ=KJ + KNOLD
      TEMP(KJ)=TEMP(KI) + DTEMP
   60 CONTINUE
C
   75 NOLD =N
      KNOLD=KN
C
      IF (N.NE.NUMNP) GO TO 30
C
      REWIND ITT
C
      WRITE (ITT) TSTART,(TEMP(I),I=1,NUMNP)
      BACKSPACE ITT
C
      RETURN
C
C
 1000 FORMAT (I5,F10.0,I5)
C
 2000 FORMAT (////42H INITIAL NODAL POINT TEMPERATURES AS INPUT//
     1        7H  CARD ,5X,6H NODE ,22X,11HNODE NUMBER/
     2        7H NUMBER,5X,6HNUMBER,5X,11HTEMPERATURE,6X,
     3        11H INCREMENT //)
 2050 FORMAT (I5,7X,I4,E18.6,5X,I7)
 2100 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE INITEM/
     2        47H WHILE READING INITIAL NODAL POINT TEMPERATURES//
     3        5X,14H NODE NUMBER =,I5/
     4        5X,14H TEMPERATURE =,E14.6/
     4        5X,24H NODE NUMBER INCREMENT =,I5//
     4        5X,26H NUMBER OF NODES (NUMNP) =,I5//
     5        39H NODE NUMBER MUST BE GT.0 AND LE.NUMNP.//
     6        12H *** S T O P)
C
      END
C *CDC* *DECK OVL20
C *CDC*       OVERLAY (ADINA,2,0)
C *CDC* *DECK TRUSS
C *UNI* )FOR,IS  N.TRUSS,  R.TRUSS
C *CDC*       PROGRAM TRUSS
      SUBROUTINE TRUSS
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   S T O R A G E                                                   .
C .                                                                   .
C .      N102    DEN    (NECESSARY FOR STATIC PROBLEMS, TOO)          .
C .      N103    AREA                                                 .
C .      N105    LM     CONNECTIVITY                                  .
C .      N106    XYZ    ELEMENT NODAL COORDINATES                     .
C .      N107    MATP   MATERIAL PROPERTY SET NUMBER                  .
C .      N108    EPSIN  INITIAL STRAIN                                .
C .      N109    IPS    STRESS PRINTING FLAG                          .
C .      N110    ETIMV  ELEMENT BIRTH/DEATH TIME (IF IDEATH.GT.0)     .
C .      N111    EDISB  ELEMENT DISPS AT BIRTH TIME (IF IDEATH.EQ.1)  .
C .      N112    WA=IWA WORKING ARRAY (SEE IDWAS)                     .
C .      N113    PROP   MATERIAL CONSTANTS (SEE NMCON)                .
C .      N114    NODGL  GLOBAL NODE NUMBERS (SEE NDWS)                .
C .      N115    IELTD  ELEMENT NUMBER OF NODES                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /DPR/ ITWO
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /ELSTP / TIME,IDTHF
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /TMODEL/ LINEL,NONEL,ITEL,ISPEL,KINPEL,IEPCI,IEPCK,MODMAX
      COMMON /SKEW  / NSKEWS
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      COMMON A(1)
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      DIMENSION DATA(20)
C
      EQUIVALENCE (NPAR(1),NPAR1), (NPAR(2),NUME), (NPAR(3),INDNL),
     1            (NPAR(4),IDEATH), (NPAR(5),ITYPT), (NPAR(7),MXNODS),
     2            (NPAR(10),NINT), (NPAR(15),MODEL), (NPAR(16),NUMMAT),
     3            (NPAR(17),NCON), (NPAR(19),IITEMP), (NPAR(6),NEGSKS)
      EQUIVALENCE (NPAR(18),IDW)
C
      DIMENSION NMCON(8),IDWAS(8),NDWS(8)
      DATA RECLB1/8HTYPE-1  /
C
      DATA NMCON / 1, 0,50, 3, 3,97,97, 0/
      DATA IDWAS / 0, 0, 0, 2, 2,12,12, 0/
      DATA NDWS / 0, 0, 1, 0, 0, 1, 1, 0/
C
C
      IF (IND.NE.0) GO TO 100
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   I N P U T   P H A S E                                           .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C     CHECK ON RANGE AND SET DEFAULTS FOR NPAR VECTOR
C
      ISTOP=0
C
      LINEL=1
      NONEL=2
      ITEL=3
      ISPEL=4
      KINPEL=5
      IEPCI=6
      IEPCK=7
      MODMAX=8
C
      IF (NUME.GT.0) GO TO 10
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=2
      IRANGE=1
      WRITE (6,2400) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   10 IF (INDNL.GE.0 .AND. INDNL.LE.2) GO TO 15
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=3
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   15 IF (IDEATH.NE.0) IDTHF=1
      IF (IDEATH.GE.0 .AND. IDEATH.LE.2) GO TO 20
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=4
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   20 IF (ITYPT.GE.0 .AND. ITYPT.LE.1) GO TO 25
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=5
      WRITE (6,2200) ISTOP,ISUB,ISUB,NPAR(ISUB)
C
   25 IF (MXNODS.LE.0) MXNODS=2
      IF (MXNODS.LE.4) GO TO 30
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=7
      IRANGE=4
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   30 NIPT=1
      IF (ITYPT.EQ.1) GO TO 34
      IF (MXNODS.GT.2) GO TO 32
      IF (MODEL.EQ.ITEL) GO TO 32
      IF(MODEL.EQ.IEPCI.OR.MODEL.EQ.IEPCK) GO TO 32
      GO TO 34
   32 NIPT=NINT
      IF (NINT.LE.0) NIPT=2
   34 NINT=NIPT
      IF (NINT.LE.4) GO TO 35
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=10
      IRANGE=4
      WRITE (6,2300) ISTOP,ISUB,IRANGE,ISUB,NPAR(ISUB)
C
   35 IF (MODEL.LE.0) MODEL=1
      IF (MODEL.LE.MODMAX) GO TO 40
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=15
      WRITE (6,2300) ISTOP,ISUB,MODMAX,ISUB,NPAR(ISUB)
C
   40 IF (NUMMAT.LE.0) NUMMAT=1
C
      IF (MODEL.EQ.MODMAX) GO TO 50
      IF (MODEL.NE.NONEL) GO TO 45
      IF (NCON.GE.4) GO TO 50
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUB=17
      IRANGE=4
      WRITE (6,2400) ISTOP,ISUB,NPAR(ISUB),IRANGE
      GO TO 50
C
   45 NCON=NMCON(MODEL)
      IDW=IDWAS(MODEL)
C
C     CHECK ON COMPATIBILITY BETWEEN ELEMENTS OF NPAR
C
C
C        1. COMPATIBILITY OF INDNL AND IDEATH
C
   50 ISUB=3
      IF (INDNL.GT.0) GO TO 55
      IF (IDEATH.EQ.0) GO TO 52
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=4
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C        2. COMPATIBILITY OF INDNL AND ITYPT
C
   52 IF (ITYPT.NE.2) GO TO 54
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=5
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C        3. COMPATIBILITY OF INDNL AND MODEL
C
   54 IF (MODEL.EQ.LINEL) GO TO 55
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      ISUD=15
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C        4. COMPATIBILITY OF MXNODS AND ITYPT
C
   55 ISUB=5
      ISUD=7
      IF (MXNODS.NE.1) GO TO 60
      IF (ITYPT.EQ.1) GO TO 56
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
      GO TO 60
C
C        5. COMPATIBILITY OF ITYPT AND NEGSKS
C
   56 ISUD=6
      IF (NEGSKS.EQ.0) GO TO 60
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2500) ISTOP,ISUB,NPAR(ISUB),ISUD,NPAR(ISUD)
C
C        6. COMPATIBILITY OF NEGSKS AND NSKEWS
C
   60 IF (NEGSKS.EQ.0) GO TO 65
      IF (NSKEWS.GT.0) GO TO 65
      ISUB=6
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2550) ISTOP,NSKEWS,ISUB,NPAR(ISUB)
C
C
C     CHECK FOR TEMPERATURE TAPE
C
   65 ITEMPR=0
      IF(MODEL.EQ.ITEL) ITEMPR=1
      IF(MODEL.EQ.IEPCI.OR.MODEL.EQ.IEPCK) ITEMPR=2
      IF (ITEMPR.EQ.0) GO TO 70
      IF (ITP96.GT.0) GO TO 70
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) WRITE (6,2100) NG
      WRITE (6,2600) ISTOP
C
   70 IITEMP=ITEMPR
C
      IF (ISTOP.EQ.0) GO TO 75
      WRITE (6,2700) ISTOP
      INPUT=5
      BACKSPACE INPUT
      READ (5,1000) DATA
      WRITE (6,2800) (I,I=1,8),DATA
      IDATWR=1
C
   75 IF (IDATWR.GT.1) GO TO 90
C
C     PRINT OUT NPAR VECTOR
C
      WRITE (6,2900) NPAR1
      WRITE (6,2905) NUME,INDNL,IDEATH
      WRITE (6,2920) ITYPT,NEGSKS,MXNODS,NINT
      WRITE (6,2940) MODEL,NUMMAT,NCON
C
   90 IF (ISTOP.EQ.0) GO TO 95
      WRITE (6,2750)
      STOP
C
C
C***  DATA PORTHOLE  *************************** (START)
C
   95 IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 100
      RECLAB=RECLB1
      WRITE (LU1) RECLAB,NG,(NPAR(I),I=1,20),NSUB
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   E N D   O F   C H E C K   O N   N P A R   V E C T O R           .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
  100 NDM=3*MXNODS
      IF (ITYPT.EQ.1) NDM=1
      NDW=NDWS(MODEL)
      IDWA=IDW*NINT
C
      NFIRST=N6
      IF (IND.EQ.4) NFIRST=N10
      N101=NFIRST + 20
      N102=N101
      N103=N102 + NUMMAT*ITWO
      N105=N103 + NUMMAT*ITWO
      N106=N105 + NDM*NUME
      N107=N106 + NDM*NUME*ITWO
      N108=N107 + NUME
      N109=N108 + NUME*ITWO
      N110=N109 + NUME
      MM=0
      IF (IDEATH.GT.0) MM=1
      N111=N110 + MM*NUME*ITWO
      MM=0
      IF (IDEATH.EQ.1) MM=1
      N112=N111 + MM*NDM*NUME*ITWO
      N113=N112 + NUME*IDWA*ITWO
      N114=N113 + NCON*NUMMAT*ITWO
      N115=N114 + NDW*NUME*MXNODS
      N116=N115 + NUME
      NLAST=N116 - 1
      IF (NEGSKS.GT.0) NLAST=N116 + (NUME*MXNODS) - 1
C
C *CDC*        IF (NLAST.GT.MTOT) CALL SIZE(NLAST+2000)
      IF (IND.NE.0) GO TO 105
      MIDEST=(NLAST-NFIRST) + 1
      IF (IDATWR.LE.1) WRITE (6,2000) NG,MIDEST
      CALL SIZE (NLAST)
C
  105 IF (IND.GT.3) GO TO 110
      M2=N2
      M3=N3
      M4=N4
      GO TO 120
  110 M2=N2
      M3=N7
      M4=N8
      IF (ICOUNT.LT.3) GO TO 120
      M2=N6
C
  120 CALL RUSS   (A(N06),A(N1A),
     1           A(N1),A(M2),A(M3),A(M4),A(N5),A(N113),A(N102),A(N103),
     1           A(N105),A(N106),A(N107),A(N108),A(N109),A(N110),
     2           A(N111),A(N112),A(N113),A(N114),A(N115),A(N116),
     2           NCON,NDOF,NDM,
     3           IDWA,A(N6A+ITWO),A(N6B+ITWO),MXNODS)
      IF (IND.GT.0) GO TO 150
      DO 140 I=1,20
  140 IA(NFIRST + I - 1)=NPAR(I)
  150 CONTINUE
C
      RETURN
C
 1000 FORMAT (20A4)
C
 2000 FORMAT (//49H LENGTH OF ARRAY NEEDED FOR STORING ELEMENT GROUP/
     3        12H DATA (GROUP,I3,26H). . . . . . . . . . . . .,
     4       15H( MIDEST ). . =,I5//)
C
 2100 FORMAT (1H1,45HERROR IN ELEMENT GROUP CONTROL CARDS  (TRUSS) /
     1        16H ELEMENT GROUP =, I5/)
 2200 FORMAT (I5,7H. NPAR(,I2,27H) IS OUT OF RANGE ... NPAR(,I2,
     1        3H) =,I5)
 2300 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .LE., I2,10H ... NPAR(,I2,
     1        3H) =,I5)
 2400 FORMAT (I5,7H. NPAR(,I2,16H) SHOULD BE .GE., I2,10H ... NPAR(,I2,
     1        3H) =,I5)
 2500 FORMAT (I5,7H. NPAR(,I2,3H) =,I2,10H AND NPAR(,I2,3H) =,I2,
     1        19H ARE NOT COMPATIBLE )
 2550 FORMAT (I5,10H. NSKEWS =,I2,10H AND NPAR(,I2,3H) =,I2,
     1        19H ARE NOT COMPATIBLE )
 2600 FORMAT (I5,37H. TEMPERATURE TAPE SHOULD BE PROVIDED )
 2700 FORMAT (//25H TOTAL NUMBER OF ERRORS =,I5//
     1        48H CARD IMAGE LISTING AND PRINT-OUT OF NPAR VECTOR/
     2        48H (WITH DEFAULTS ENFORCED) ARE GIVEN BELOW ------)
 2800 FORMAT (///34H CARD IMAGE LISTING OF NPAR VECTOR //29X,8(I1,9X)/
     1        15H COLUMN NUMBERS,5X,8(10H1234567890)/
     2        15H NPAR VECTOR   ,5X,20A4 // )
 2750 FORMAT (//// 23H STOP  (ERRORS IN NPAR)  )
C
 2900 FORMAT (36H E L E M E N T   D E F I N I T I O N ///,
     1        14H ELEMENT TYPE ,13(2H .),16H( NPAR(1) ). . =,I5/,
     2        25H     EQ.1, TRUSS ELEMENTS/,
     3        25H     EQ.2, 2-DIM ELEMENTS/,
     4        25H     EQ.3, 3-DIM ELEMENTS/,
     5        25H     EQ.4, BEAM  ELEMENTS/,
     5        28H     EQ.5, ISO/BEAM ELEMENTS/,
     6        28H     EQ.6, PLATE ELEMENTS   /,
     C        25H     EQ.7, SHELL ELEMENTS/,
     D        25H     EQ.8,9,10, EMPTY    /,
     G        32H     EQ.11, 2-DIM FLUID ELEMENTS/,
     5        32H     EQ.12, 3-DIM FLUID ELEMENTS   /)
 2905 FORMAT (20H NUMBER OF ELEMENTS.,10(2H .),16H( NPAR(2) ). . =,I5//,
     7        28H TYPE OF NONLINEAR ANALYSIS.,6(2H .),15H( NPAR(3) ). .
     8        1H=,I5/,
     9        38H     EQ.0, LINEAR                      /,
     A        38H     EQ.1, MATERIALLY NONLINEAR ONLY   /,
     1        45H     EQ.2, UPDATED LAGRANGIAN FORMULATION          //
     2        32H ELEMENT BIRTH AND DEATH OPTIONS ,4(2H .),
     3        16H( NPAR(4) ). . =,I5/,
     4        28H     EQ.0, OPTION NOT ACTIVE/,
     5        30H     EQ.1, BIRTH OPTION ACTIVE /,
     6        30H     EQ.2, DEATH OPTION ACTIVE //)
 2920 FORMAT (18H ELEMENT TYPE CODE,11(2H .),16H( NPAR(5) ). . =,I5/,
     1        40H     EQ.0, GENERAL 3-D TRUSS                   /,
     2        40H     EQ.1, RING ELEMENT                           //,
     A        23H SKEW COORDINATE SYSTEM/
     B        40H     REFERENCE INDICATOR . . . . . . . .,
     C        16H( NPAR(6) ). . =,I5/
     D        28H     EQ.0, ALL ELEMENT NODES/
     E        37H           USE THE GLOBAL SYSTEM ONLY/
     F        35H     EQ.1, ELEMENT NODES REFER     /
     G        36H           TO SKEW COORDINATE SYSTEM//
     4        42H MAXIMUM NUMBER OF NODES USED TO DESCRIBE  /,4X,
     5        16H ANY ONE ELEMENT,10(2H .),16H( NPAR(7) ). . =,I5//,
     6        35H INTEGRATION ORDER FOR STIFFNESS      /,4X,
     7        12H CALCULATION,12(2H .),16H( NPAR(10)). . =,I5///)
 2940 FORMAT (42H M A T E R I A L   D E F I N I T I O N     ///,
     1        16H MATERIAL MODEL.,12(2H .),16H( NPAR(15)). . =,I5/,
     2        40H    EQ.1,   LINEAR ELASTIC                     /,
     3        40H    EQ.2,   NONLINEAR ELASTIC                  /,
     4        42H            (STRESS-STRAIN LAW SPECIFIED)      /,
     5        40H    EQ.3,   THERMOELASTIC                      /,
     6        44H    EQ.4,   ELASTIC-PLASTIC (ISOTROPIC)     ,/,
     A        44H    EQ.5,   ELASTIC-PLASTIC (KINEMATIC)     ,/,
     7       48H    EQ.6,   ELASTIC-PLASTIC-CREEP (ISOTROPIC)   ,/,
     B       48H    EQ.7,   ELASTIC-PLASTIC-CREEP (KINEMATIC)   ,/,
     C       40H    EQ.8,   USER SUPPLIED MODEL         ,//,
     8        37H NUMBER OF DIFFERENT SETS OF MATERIAL          /,
     9        14H     CONSTANTS,13(2H .),16H( NPAR(16)). . =,I5//,
     B        40H NUMBER OF MATERIAL CONSTANTS PER SET. .  ,
     1        16H( NPAR(17)). . =,I5)
C
      END
C *CDC* *DECK RUSS
C *UNI* )FOR,IS  N.RUSS,   R.RUSS
      SUBROUTINE RUSS (RSDCOS,NODSYS,ID,X,Y,Z,HT,E,DEN,AREA,LM,XYZ,MATP,
     1                 EPSIN,IPS,ETIMV,EDISB,WA,PROP,NODGL,IELTD,ISKEW,
     2                 NCON,NDOF,NDM,IDWA,TEMPV1,TEMPV2,MXNODS)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /EM1D/ S(78),XM(24),ST(6),D(4),RE(24)
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /MDFRDM/ IDOF(6)
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /TRNODE/ IELD,ND,RST(12),DISP(12),PP(4),STS(4),STN(4),RL(4)
      COMMON /TMODEL/ LINEL,NONEL,ITEL,ISPEL,KINPEL,IEPCI,IEPCK,MODMAX
      COMMON /SKEW  / NSKEWS
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      COMMON A(1)
      REAL A
C
      DIMENSION ID(NDOF,1),X(1),Y(1),Z(1),HT(1),E(1),DEN(1),AREA(1),
     1          LM(NDM,1),XYZ(NDM,1),MATP(1),EPSIN(1),IPS(1),ETIMV(1),
     2          EDISB(NDM,1),WA(IDWA,1),PROP(NCON,1),
     3          NODGL(MXNODS,1),IELTD(1),TEMPV1(1),TEMPV2(1)
      DIMENSION RSDCOS(9,1),NODSYS(1),ISKEW(MXNODS,1)
C
      DIMENSION B(12),NODE(4),NODEM(4),PM(4),H(4),HR(4),XYZINT(3,4)
C
      EQUIVALENCE (NPAR(1),NPAR1), (NPAR(2),NUME), (NPAR(3),INDNL),
     1            (NPAR(4),IDEATH), (NPAR(5),ITYPT), (NPAR(10),NINT),
     2            (NPAR(15),MODEL), (NPAR(16),NUMMAT), (NPAR(6),NEGSKS)
C
      DATA RECLB1/8HMATERAL1/, RECLB2/8HELEMENT1/,
     1     RECLB3/8HNEWSTEP1/, RECLB4/8HOUTPUT-1/, RECLB5/8HIPOINT-1/
      DATA HEAD1/6HRADIUS/, HEAD2/6HLENGTH/
C
C     ** NOTE ** DURING THE TIME INTEGRATION, X=DISP, Y=VEL, Z=ACC
C
      IELCPL=0
      IF (KPRI.EQ.0) GO TO 800
      IF (IND.GT.0) GO TO 420
      IJPORT=1
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) IJPORT=0
C
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   R E A D   A N D   G E N E R A T E   E L E M E N T               .
C .   I N F O R M A T I O N                                           .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
C        1. READ MATERIAL PROPERTIES
C
C
      IF (IDATWR.LE.1) WRITE (6,2000)
      IBUG=0
C
      GO TO (10,20,30,40,40,60,60,70), MODEL
C
C     LINEAR ELASTIC  (MODEL 1)
C
   10 IF (IDATWR.LE.1) WRITE (6,2010)
      DO 15 I=1,NUMMAT
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) E(N)
      IF (IDATWR.LE.1) WRITE (6,2011) N,AREA(N),DEN(N),E(N)
   15 CONTINUE
C
C
C
C***  DATA PORTHOLE  **************************** (START)
C
      IF (IJPORT.EQ.0) GO TO 150
      RECLAB=RECLB1
      WRITE (LU1) RECLAB,NUMMAT,NCON,(DEN(I),I=1,NUMMAT),
     1            (E(I),I=1,NUMMAT),(AREA(I),I=1,NUMMAT)
C
C***  DATA PORTHOLE  **************************** ( END )
C
      GO TO 150
C
C     NONLINEAR ELASTIC  (MODEL 2)
C
   20 IP=NCON/2
      DO 25 I=1,NUMMAT
      KP=1
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) (PROP(J,N),J=1,NCON)
      IF (IDATWR.GT.1) GO TO 25
      WRITE (6,2020) N,AREA(N),DEN(N),KP,PROP(1,N),PROP(IP+1,N)
      DO 22 K=2,IP
      KP=K+IP
      ETAN=(PROP(KP,N)-PROP(KP-1,N))/(PROP(K,N)-PROP(K-1,N))
   22 WRITE (6,2021) K,PROP(K,N),PROP(KP,N),ETAN
   25 CONTINUE
      GO TO 98
C
C     THERMOELASTIC  (MODEL 3)
C
   30 DO 39 I=1,NUMMAT
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) (PROP(J,N),J=1,NCON)
      IF(IDATWR.LE.1) WRITE(6,2030) N,AREA(N),DEN(N)
C
      NPTS=IDINT(PROP(49,N))
      IF(NPTS.GT.0) GO TO 32
      PROP(49,N)=16.0
      NPTS=16
      GO TO 34
C
   32 IF(NPTS.GE.2 .AND. NPTS.LE.16) GO TO 34
      IBUG=1
      WRITE(6,3002)
      GO TO 37
C
   34 DO 35 J=2,NPTS
      JJ=J-1
      IF(PROP(J,N).GT.PROP(JJ,N)) GO TO 35
      IBUG=1
      WRITE(6,3003)
      GO TO 37
   35 CONTINUE
C
   37 IF(IDATWR.GT.1) GO TO 39
      WRITE(6,2031)
      DO 38 K=1,16
      IP1=K + 16
      IP2=K + 32
   38 WRITE(6,2032) PROP(K,N),PROP(IP1,N),PROP(IP2,N)
      WRITE(6,2033) PROP(49,N),PROP(50,N)
C
   39 CONTINUE
      IF(MODEX.EQ.0.OR.IBUG.EQ.0) GO TO 98
      STOP
C
C     ELASTIC-PLASTIC MODELS  (MODEL 4  AND  MODEL 5)
C
   40 IF (IDATWR.LE.1) WRITE (6,2040)
      DO 45 I=1,NUMMAT
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) (PROP(J,N),J=1,NCON)
      IF (IDATWR.GT.1) GO TO 42
      WRITE (6,2011) N,AREA(N),DEN(N),(PROP(J, N),J=1,NCON)
   42 IF (PROP(2,N).GT.0.0) GO TO 41
      IBUG=1
      WRITE (6,3401) NG,N
   41 IF (PROP(3,N).LT.PROP(1,N)) GO TO 45
      IBUG=1
      WRITE (6,3402) NG,N
   45 CONTINUE
      IF (MODEX.EQ.0 .OR. IBUG.EQ.0) GO TO 98
      WRITE (6,3403)
      STOP
C
C
C      THERMO-ELASTIC-PLASTIC AND CREEP MODELS  (MODEL 6 AND MODEL 7)
C
   60 DO 69 I=1,NUMMAT
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) (PROP(J,N),J=1,NCON)
      IF(IDATWR.LE.1) WRITE(6,2030) N,AREA(N),DEN(N)
C
      NPTS=IDINT(PROP(89,N))
      XCRP=PROP(91,N)
      XINTP=PROP(92,N)
      XSUBM=PROP(93,N)
      XITE=PROP(94,N)
      XALG=PROP(95,N)
      TOLIL=PROP(96,N)
      TOLPC=PROP(97,N)
C
      IF(NPTS.GT.0) GO TO 61
      PROP(89,N)=16.0
      NPTS=16
C
   61 IF (XSUBM.EQ.0.0) PROP(93,N)=10.0
      IF (XALG.EQ.2.0 .AND. XSUBM.LT.3.0) PROP(93,N)=3.0
      IF (XITE.EQ.0.0) PROP(94,N)=15.0
      IF (XALG.EQ.0.0) PROP(95,N)=1.0
      IF (TOLIL.EQ.0.0) PROP(96,N)=5.0D-3
      IF (TOLPC.EQ.0.0) PROP(97,N)=1.0D-1
C
      IF(XCRP.GE.0.0 .AND. XCRP.LE.2.0) GO TO 62
      WRITE(6,3000)
      IBUG=1
C
   62 IF(XINTP.GE.0.0 .AND. XINTP.LE.1.0) GO TO 63
      WRITE(6,3001)
      IBUG=1
C
   63 IF(NPTS.GE.2 .AND. NPTS.LE.16) GO TO 64
      IBUG=1
      WRITE(6,3002)
      GO TO 66
C
   64 DO 65 J=2,NPTS
      JJ=J - 1
      IF(PROP(J,N).GT.PROP(JJ,N)) GO TO 65
      IBUG=1
      WRITE(6,3003)
      GO TO 66
   65 CONTINUE
C
   66 IF(IDATWR.GT.1) GO TO 68
      WRITE(6,2061)
      DO 67 K=1,16
      IP1=K + 16
      IP2=K + 32
      IP3=K + 48
      IP4=K + 64
   67 WRITE(6,2062) PROP(K,N),PROP(IP1,N),PROP(IP2,N),PROP(IP3,N),
     1              PROP(IP4,N)
      WRITE(6,2063) (PROP(K,N),K=81,88)
      WRITE(6,2064) (PROP(K,N),K=89,97)
C
   68 IF(PROP(94,N).LT.6.0) WRITE(6,2065)
C
   69 CONTINUE
      IF(MODEX.EQ.0.OR.IBUG.EQ.0) GO TO 98
      STOP
C
C
C      USER SUPPLIED MODEL  (MODEL 8)
C
   70 DO 75 I=1,NUMMAT
      READ (5,1000) N,AREA(N),DEN(N)
      READ (5,1010) (PROP(J,N),J=1,NCON)
      IF (IDATWR.GT.1) GO TO 75
      WRITE (6,2030) N,AREA(N),DEN(N)
      WRITE (6,2071) (J,N,PROP(J,N),J=1,NCON)
   75 CONTINUE
C
C
C***  DATA PORTHOLE  *************************** (START)
C
   98 IF (IJPORT.EQ.0) GO TO 150
      RECLAB=RECLB1
      WRITE (LU1)  RECLAB,NUMMAT,NCON,(DEN(I),I=1,NUMMAT),
     1             ((PROP(I,J),I=1,NCON),J=1,NUMMAT),
     2             (AREA(I),I=1,NUMMAT)
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
C        2. READ ELEMENT INFORMATION
C
  150 HEAD=HEAD1
      IF (ITYPT.EQ.0) HEAD=HEAD2
      ISCONT=0
      IF (NSKEWS.GT.0 .AND. NEGSKS.EQ.0) ISCONT=1
      IF (IDATWR.LE.1) WRITE(6,2200) HEAD
      N=1
C
      IREAD=5
      IF (INPORT.GT.0) IREAD=59
  160 READ (IREAD,1100) M,IELE,IS,MTYP,KG,EPS,ETIME,INTLOC
      READ (IREAD,1200) NODE
C
      IF (N.EQ.1 .AND. M.NE.1) GO TO 115
      IF (IDEATH.EQ.2 .AND. ETIME.EQ.0.) ETIME=100000.
      IF (IELE.EQ.0) IELE=MXNODS
      IF (MTYP.LE.0) MTYP=1
      IF (MTYP.GT.NUMMAT) GO TO 110
      IF (KG.LE.0) KG=1
      IF (IELE.LE.MXNODS) GO TO 120
C
      WRITE (6,2300) NG,M,IELE,MXNODS
      STOP
C
  110 WRITE (6,2310) NG,M,MTYP,NUMMAT
      STOP
  115 WRITE (6,2315) NSUB,NG
      STOP
C
  120 IF(M.NE.N) GO TO 200
  121 DO 122 I=1,IELE
  122 NODEM(I)=NODE(I)
      MTYPE=MTYP
      KKK=KG
      EPSI=EPS
      IPST=IS
      ETIM=ETIME
      IELD=IELE
      INTLM=INTLOC
C
C     SAVE ELEMENT INFORMATION
C
  200 IF (ITYPT.NE.1) GO TO 195
      I=NODEM(1)
      XYZ(1,N)=Y(I)
      GO TO 201
C
  195 L=-2
      DO 190 LL=1,IELD
      L=L + 3
      I=NODEM(LL)
      IF (ISCONT.EQ.0) GO TO 170
      IF (NODSYS(I).EQ.0) GO TO 175
      WRITE (6,2410) NG,N,NEGSKS
      STOP
  170 IF (NEGSKS.GT.0) ISKEW(LL,N)=NODSYS(I)
  175 XYZ(L,N)=X(I)
      XYZ(L+1,N)=Y(I)
  190 XYZ(L+2,N)=Z(I)
      IF (NEGSKS.EQ.0) GO TO 201
      DO 192 LL=1,IELD
      IF (ISKEW(LL,N).NE.0) GO TO 201
  192 CONTINUE
      ISKEW(1,N)=-1
C
C
  201 MATP(N)=MTYPE
      EPSIN(N)=EPSI
      IPS(N)=IPST
      IELTD(N)=IELD
      ND=3*IELD
      IF (ITYPT.EQ.1) ND=1
C
C     INITIALIZE WORKING STORAGE
C
      IF(MODEL.LT.3) GO TO 204
C
      CALL IMATB (PROP(1,MTYPE),WA(1,N),WA(1,N),NODGL(1,N),
     1            TEMPV1,NODEM,IELD)
C
  204 IF (IDEATH.EQ.0) GO TO 210
      IF (IDEATH.EQ.2) GO TO 207
      DO 208 L=1,ND
  208 EDISB(L,N)=0.
      ETIMV(N)=-ETIM
      GO TO 210
  207 ETIMV(N)=ETIM
C
  210 IF (ITYPT.NE.1) GO TO 211
      LDO=1
      IF (IDOF(1).EQ.0) LDO=2
      LM(1,N)=0
      IF (IDOF(2).EQ.1) GO TO 295
      II=NODEM(1)
      LM(1,N)=ID(LDO,II)
      GO TO 295
C
  211 DO 290 L=1,ND
  290 LM(L,N)=0
      LL=1
      DO 240 L=1,3
      IF (IDOF(L).EQ.1) GO TO 240
      LP=L - 3
      DO 241 LK=1,IELD
      LP=LP + 3
      II=NODEM(LK)
      LM(LP,N)=ID(LL,II)
  241 CONTINUE
      LL=LL + 1
  240 CONTINUE
  295 CONTINUE
C
C     UPDATE COLUMN HEIGHTS AND BANDWIDTH
C
      CALL COLHT (HT,ND,LM(1,N))
C
      IF (IDATWR.GT.1) GO TO 296
      RL(1)=XYZ(1,N)
      IF (ITYPT.EQ.0) CALL LENTH1 (XYZ(1,N),RL)
      WRITE (6,2210) N,IELTD(N),IPS(N),MATP(N),KKK,EPSIN(N),RL(1),ETIM,
     1               INTLM,(NODEM(LL),LL=1,IELD)
C
C     CALCULATE GLOBAL COORDINATES OF INTEGRATION POINTS
C     NOT APPLICABLE FOR RING ELEMENTS OR 2-NODE TRUSSES
C
  296 IF (ITYPT.EQ.1) GO TO 319
      IF (IJPORT.EQ.0 .AND. INTLM.EQ.0) GO TO 300
      KINTP=0
      DO 297 LX=1,NINT
      RINTP=XG(LX,NINT)
      KINTP=KINTP+1
C
      CALL FUNCT1 (H,HR,RINTP,IELD,1,0)
C
      IX=0
      XINT=0.
      YINT=0.
      ZINT=0.
      DO 299 NDPT=1,IELD
      IX=IX+3
      XINT=XINT + H(NDPT)*XYZ(IX-2,N)
      YINT=YINT + H(NDPT)*XYZ(IX-1,N)
  299 ZINT=ZINT + H(NDPT)*XYZ(IX,N)
C
      XYZINT(1,KINTP)=XINT
      XYZINT(2,KINTP)=YINT
      XYZINT(3,KINTP)=ZINT
C
C     PRINT LOCATIONS IF INTLM.GT.0
C
      IF (IDATWR.LE.1 .AND. INTLM.GT.0)
     1 WRITE (6,2208) KINTP,(XYZINT(L,KINTP),L=1,3)
  297 CONTINUE
      GO TO 298
  319 IF (IDATWR.LE.1 .AND. INTLM.GT.0)
     1 WRITE (6,2209)
C
C
C***  DATA PORTHOLE  *************************** (START)
C
  298 IF (IJPORT.EQ.0) GO TO 300
      RECLAB=RECLB2
      WRITE (LU1) RECLAB,N,IELTD(N),IPS(N),MATP(N),KKK,EPSIN(N),ETIM,
     1            (NODEM(LL),LL=1,IELD)
      RECLAB = RECLB5
      IF (ITYPT.NE.1)
     1  WRITE (LU1) RECLAB,NINT,((XYZINT(L,I),L=1,3),I=1,NINT)
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
  300 IF (N.EQ.NUME) GO TO 325
      N=N+1
      DO 220 LL=1,IELD
  220 NODEM(LL)=NODEM(LL) + KKK
      IF (N-M) 200,121,160
C
  325 IF (NEGSKS.EQ.0) RETURN
      DO 340 N=1,NUME
      IF (ISKEW(1,N).GE.0) GO TO 350
  340 CONTINUE
      WRITE (6,2400) NG,NEGSKS
C
  350 RETURN
C
C
  420 GO TO (440,560,560,700) ,IND
C
C
C    A S S E M B L E   L I N E A R   S T I F F N E S S   M A T R I C E S
C
C
  440 DO 500 N=1,NUME
      IELD=IELTD(N)
      ND=IELD*3
      IF (ITYPT.EQ.1) ND=1
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 500
      MTYPE=MATP(N)
      IF (ITYPT.NE.1) GO TO 501
C
C     RING ELEMENT
C
      ND=1
      S(1)=E(MTYPE)*AREA(MTYPE)/XYZ(1,N)
      GO TO 520
C
C     2-4 NODE TRUSS
C
  501 AE=AREA(MTYPE)*E(MTYPE)
      CALL LENTH1 (XYZ(1,N),RL)
      CALL STIF1 (XYZ(1,N),AE,S)
      IF (NEGSKS.EQ.0) GO TO 520
      IF (ISKEW(1,N).LT.0) GO TO 520
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
C
  520 CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  500 CONTINUE
      RETURN
C
C
C    A S S E M B L E   M A S S   M A T R I C E S
C
C
  560 IF (IMASS.EQ.2) GO TO 550
C
C     LUMPED MASS DISCRETIZATION
C
  545 DO 640 N=1,NUME
      MTYPE=MATP(N)
      IELD=IELTD(N)
      ND=IELD*3
C
      IF (ITYPT.NE.1) GO TO 546
      XM(1)=XYZ(1,N)*AREA(MTYPE)*DEN(MTYPE)
      ND=1
      GO TO 547
C
  546 CALL LENTH1 (XYZ(1,N),RL)
C
      PM(1)=.5*RL(2)
      GO TO (900,620,625,626), IELD
  620 PM(2)=PM(1)
      GO TO 627
  625 PM(2)=.5*(RL(1)-RL(2))
      PM(3)=.5*RL(1)
      GO TO 627
  626 PM(2)=.5*(RL(1)-RL(3))
      PM(3)=.5*RL(3)
      PM(4)=.5*(RL(1)-RL(2))
C
  627 K=0
      ADEN=AREA(MTYPE)*DEN(MTYPE)
      DO 628 I=1,IELD
      XMM=ADEN*PM(I)
      DO 628 L=1,3
      K=K+1
  628 XM(K)=XMM
C
  547 CALL ADDMA (A(N4),XM,LM(1,N),ND)
  640 CONTINUE
C
      RETURN
C
C     CONSISTENT MASS DISCRETIZATION
C
  550 DO 650 N=1,NUME
      IELD=IELTD(N)
      ND=IELD*3
      IF (ITYPT.EQ.1) ND=1
      CALL ECHECK(LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) GO TO 650
      MTYPE=MATP(N)
C
      IF (ITYPT.NE.1) GO TO 651
      XM(1)=XYZ(1,N)*AREA(MTYPE)*DEN(MTYPE)
      ND=1
      GO TO 655
C
  651 ADEN=AREA(MTYPE)*DEN(MTYPE)
      CALL LENTH1 (XYZ(1,N),RL)
      CALL MASBAR (XYZ(1,N),ADEN,S)
      IF (NEGSKS.EQ.0) GO TO 655
      IF (ISKEW(1,N).LT.0) GO TO 655
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
C
  655 CALL ADDBAN (A(N2),A(N1),S,RE,LM(1,N),ND,1)
  650 CONTINUE
C
      RETURN
C
C
C     A S S E M B L E   N O N L I N E A R   F I N A L   S T R U C  -
C     T U R E   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
C     V E C T O R S
C
  700 ISTIF=0
      IF (ICOUNT.EQ.3) GO TO 703
      IF (IREF.EQ.0) ISTIF=1
  703 CONTINUE
      MADR=N3
      IF (ICOUNT.EQ.3) MADR=N5
C
      DO 710 N=1,NUME
      IELD=IELTD(N)
      ND=IELD*3
      IF (ITYPT.EQ.1) ND=1
      CALL ECHECK (LM(1,N),ND,ICODE,IUPDT)
      IF (ICODE.EQ.1) IELCPL=IELCPL + 1
      IF (ICODE.EQ.1) GO TO 710
      IF (IDEATH.EQ.0) GO TO 692
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 690
      IF (TIME.LT.ETIM) GO TO 710
      IF (ETIMV(N).GE.0.) GO TO 692
      ETIMV(N)=ETIM
      DO 695 L=1,ND
      I=LM(L,N)
      IF (I) 693,695,694
  693 I=NEQ - I
  694 EDISB(L,N)=X(I)
  695 CONTINUE
      IF (ITYPT.EQ.1) GO TO 692
      IF (NEGSKS.EQ.0) GO TO 692
      IF (ISKEW(1,N).LT.0) GO TO 692
      CALL DIRCOS (RSDCOS,EDISB(1,N),ISKEW(1,N),IELD,3,1)
      GO TO 692
  690 IF (TIME.GT.ETIM) GO TO 710
  692 MTYPE=MATP(N)
C
      IF (ITYPT.NE.1) GO TO 701
      ND=1
      RST(1)=XYZ(1,N)
      DISP(1)=0.
      I=LM(1,N)
      IF (I.GT.0) DISP(1)=X(I)
      IF (I.LT.0) DISP(1)=X(NEQ - I)
      IF (IDEATH.NE.1) GO TO 706
      RST(1)=RST(1) + EDISB(1,N)
      DISP(1)=DISP(1) - EDISB(1,N)
      GO TO 706
C
  701 DO 702 L=1,ND
      RST(L)=XYZ(L,N)
      DISP(L)=0.
      I=LM(L,N)
      IF (I.GT.0) DISP(L)=X(I)
      IF (I.LT.0) DISP(L)=X(NEQ - I)
      IF (IDEATH.NE.1) GO TO 702
      RST(L)=RST(L) + EDISB(L,N)
  702 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 720
      IF (ISKEW(1,N).LT.0) GO TO 720
      CALL DIRCOS (RSDCOS,DISP,ISKEW(1,N),IELD,3,1)
  720 IF (IDEATH.NE.1) GO TO 706
      DO 725 L=1,ND
  725 DISP(L)=DISP(L) - EDISB(L,N)
C
C
  706 CALL STIFN1 (N,AREA(MTYPE),PROP(1,MTYPE),WA(1,N),
     1             NODGL(1,N),TEMPV1,TEMPV2,EPSIN(N),S,RE,ISTIF,IPST)
C
      IF (NEGSKS.EQ.0) GO TO 730
      IF (ISKEW(1,N).LT.0) GO TO 730
      CALL DIRCOS (RSDCOS,RE,ISKEW(1,N),IELD,3,2)
C
  730 CALL ADDBAN (A(MADR),A(N1),S,RE,LM(1,N),ND,2)
      IF (ISTIF.EQ.0) GO TO 710
C
C     ADD ELEMENT STIFFNESS
C
      IF (NEGSKS.EQ.0) GO TO 735
      IF (ISKEW(1,N).LT.0) GO TO 735
      CALL ATKA (RSDCOS,S,ISKEW(1,N),IELD,3)
  735 CALL ADDBAN (A(N4),A(N1),S,RE,LM(1,N),ND,1)
C
  710 CONTINUE
      IF (IELCPL.EQ.NUME) IELCPL=-1
      RETURN
C
C
C     S T R E S S   C A L C U L A T I O N S
C
C
C
C***  DATA PORTHOLE  *************************** (START)
C
  800 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 802
      RECLAB=RECLB3
      WRITE (LU1)  RECLAB,NG,(NPAR(I),I=1,20),KSTEP,TIME,NEGL,NSUB
C
C***  DATA PORTHOLE  *************************** ( END )
C
  802 IF (NG.GT.NEGL) GO TO 805
C
C     GEOMETRIC AND MATERIAL LINEAR STRESS CALCULATION
C
      IPRNT=0
      IPORT=JNPORT*KPLOTE
C
      DO 830 N=1,NUME
      IPST=IPS(N)
      IF (IPST.EQ.0) GO TO 830
      IF (IPRI.NE.0) GO TO 801
      IPRNT=IPRNT + 1
      IF (IPRNT.NE.1) GO TO 801
      WRITE (6,2500) NG
  801 MTYPE=MATP(N)
      IELD=IELTD(N)
      ND=IELD*3
C
      IF (ITYPT.NE.1) GO TO 811
      ND=1
      EP=EPSIN(N)
      I=LM(1,N)
      IF (I.GT.0) EP=EP + X(I)/XYZ(1,N)
      IF (I.LT.0) EP=EP + X(NEQ - I)/XYZ(1,N)
      STN(1)=EP
      STS(1)=E(MTYPE)*EP
      PP(1)=AREA(MTYPE)*STS(1)
      IF (IPRI.EQ.0) WRITE(6,2510) N,ND,PP(1),STS(1),STN(1)
      GO TO 816
C
  811 CONTINUE
      DO 815 J=1,ND
      DISP(J)=0.
      I=LM(J,N)
      IF (I) 819,815,820
  819 I=NEQ - I
  820 DISP(J)=X(I)
  815 CONTINUE
C
      IF (NEGSKS.EQ.0) GO TO 812
      IF (ISKEW(1,N).LT.0) GO TO 812
      CALL DIRCOS (RSDCOS,DISP,ISKEW(1,N),IELD,3,1)
  812 CALL LENTH1 (XYZ(1,N),RL)
C
      DO 814 L=1,NINT
      EP=EPSIN(N)
      R=XG(L,NINT)
      CALL DERIQ1 (XYZ(1,N),R,B,XJ)
      DO 813 K=1,ND
  813 EP=EP + B(K)*DISP(K)
      STN(L)=EP
      STS(L)=E(MTYPE)*EP
      PP(L)=STS(L)*AREA(MTYPE)
      IF (IPRI.EQ.0) WRITE(6,2510) N,L,PP(L),STS(L),STN(L)
  814 CONTINUE
      IF (IPRI.EQ.0) WRITE(6,2520)
C
C
C***  DATA PORTHOLE  *************************** (START)
C
  816 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 830
      RECLAB=RECLB4
      DO 817 L=1,NINT
      WRITE (LU1) RECLAB,L,PP(L),STS(L),STN(L)
  817 CONTINUE
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
  830 CONTINUE
C
      RETURN
C
C
C      NONLINEAR STRESS CALCULATION
C
  805 IPRNT=0
      DO 810 N=1,NUME
      IF (IDEATH.EQ.0) GO TO 910
      ETIM=DABS(ETIMV(N))
      IF (IDEATH.EQ.2) GO TO 890
      IF (TIME.LT.ETIM) GO TO 810
      GO TO 910
  890 IF (TIME.GT.ETIM) GO TO 810
  910 IPST=IPS(N)
      IF (IPST.EQ.0) GO TO 810
      IF(IPRI.NE.0) GO TO 803
      IPRNT=IPRNT + 1
      IF (IPRNT.NE.1) GO TO 803
      GO TO (870,870,872,874,874,875,875,870), MODEL
  870 WRITE(6,2650) NG
      GO TO 803
  872 WRITE(6,2500) NG
      GO TO 803
  874 WRITE(6,2600) NG
      GO TO 803
  875 WRITE(6,2550) NG
C
  803 IF (IPRI.EQ.0) WRITE(6,2520)
      MTYPE=MATP(N)
      IELD=IELTD(N)
      ND=IELD*3
C
      IF (ITYPT.NE.1) GO TO 850
      ND=1
      RST(1)=XYZ(1,N)
      DISP(1)=0.
      I=LM(1,N)
      IF (I.GT.0) DISP(1)=X(I)
      IF (I.LT.0) DISP(1)=X(NEQ - I)
      IF (IDEATH.NE.1) GO TO 860
      RST(1)=RST(1) + EDISB(1,N)
      DISP(1)=DISP(1) - EDISB(1,N)
      GO TO 860
C
  850 DO 851 L=1,ND
      RST(L)=XYZ(L,N)
      DISP(L)=0.
      I=LM(L,N)
      IF (I) 852,851,853
  852 I=NEQ - I
  853 DISP(L)=X(I)
      IF (IDEATH.NE.1) GO TO 851
      RST(L)=RST(L) + EDISB(L,N)
  851 CONTINUE
      IF (NEGSKS.EQ.0) GO TO 855
      IF (ISKEW(1,N).LT.0) GO TO 855
      CALL DIRCOS (RSDCOS,DISP,ISKEW(1,N),IELD,3,1)
  855 IF (IDEATH.NE.1) GO TO 860
      DO 856 L=1,ND
  856 DISP(L)=DISP(L) - EDISB(L,N)
C
C
  860 CALL STIFN1 (N,AREA(MTYPE),PROP(1,MTYPE),WA(1,N),
     1             NODGL(1,N),TEMPV1,TEMPV2,EPSIN(N),S,RE,0,IPST)
C
C
C***  DATA PORTHOLE  *************************** (START)
C
      IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 810
      RECLAB=RECLB4
      DO 880 L=1,NINT
      WRITE (LU1) RECLAB,L,PP(L),STS(L),STN(L)
  880 CONTINUE
C
C***  DATA PORTHOLE  *************************** ( END )
C
C
  810 CONTINUE
C
      RETURN
C
  900 STOP
C
C
 1000 FORMAT (I5,4F10.0)
 1010 FORMAT (8F10.0)
 1100 FORMAT (5I5,2F10.0,I5)
 1200 FORMAT (16I5)
C
 2000 FORMAT (////37H M A T E R I A L    C O N S T A N T S)
 2010 FORMAT (///5H  SET,10X,5H AREA,10X,5H  DEN,10X,5H    E/)
 2011 FORMAT (I5,8E15.6)
 2020 FORMAT (///5H  SET,10X,5H AREA,10X,5H  DEN,12X,5HPOINT,9X,
     1        6HSTRAIN,9X,6HSTRESS,11X,4HETAN/ I5,2E15.6,12X,I5,2E15.6)
 2021 FORMAT (47X,I5,3E15.6)
 2030 FORMAT (///27H MATERIAL CONSTANTS SET NO.,I5/
     1        14H     AREA    =,E15.6/14H     DENSITY =,E15.6/)
 2031 FORMAT (1H ,4X,17HTEMP (PROP(1-16)),5X,15HE (PROP(17-32)),5X,
     1        19HALPHA (PROP(33-48)),/)
 2032 FORMAT (1H ,4X,3(E14.6,7X))
 2033 FORMAT ( //,4X,46HNUMBER OF TEMPERATURE POINTS ...(PROP(49)).. =,
     1        E14.6,/,
     2        1H ,3X,46HREFERENCE TEMPERATURE ..........(PROP(50)).. =,
     3        E14.6,//)
 2040 FORMAT (///5H  SET,10X,5H AREA,10X,5H  DEN,10X,5H    E,
     1        10X,5HYIELD,10X,5H   ET /)
 2061 FORMAT (1H ,4X,17HTEMP (PROP(1-16)),5X,15HE (PROP(17-32)),5X,
     1        19HYIELD (PROP(33-48)),3X,16HET (PROP(49-64)),4X,
     2        19HALPHA (PROP(65-80)),/)
 2062 FORMAT (1H ,4X,5(E14.6,7X))
 2063 FORMAT (1H ,//,5X,33HCREEP LAW COEFFICIENTS ..........,//,
     1        1H ,4X,29HA0 ............(PROP(81)).. =,E14.6,/,
     2        1H ,4X,29HA1 ............(PROP(82)).. =,E14.6,/,
     3        1H ,4X,29HA2 ............(PROP(83)).. =,E14.6,/,
     4        1H ,4X,29HA3 ............(PROP(84)).. =,E14.6,/,
     5        1H ,4X,29HA4 ............(PROP(85)).. =,E14.6,/,
     6        1H ,4X,29HA5 ............(PROP(86)).. =,E14.6,/,
     7        1H ,4X,29HA6 ............(PROP(87)).. =,E14.6,/,
     8        1H ,4X,29HA7 ............(PROP(88)).. =,E14.6,//)
 2064 FORMAT (1H ,4X,65HNUMBER OF TEMPERATURE POINTS ...................
     1...(PROP(89)).. =,E14.6,/,
     2        1H ,4X,65HREFERENCE TEMPERATURE ..........................
     3...(PROP(90)).. =,E14.6,/,
     4        1H ,4X,65HCREEP LAW KEY ..................................
     5...(PROP(91)).. =,E14.6,/,
     6        1H ,4X,65HINTEGRATION PARAMETER ..........................
     7...(PROP(92)).. =,E14.6,/,
     8        1H ,4X,65HMAXIMUM NUMBER OF SUBDIVISIONS .................
     9...(PROP(93)).. =,E14.6,/,
     A        1H ,4X,65HMAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION ...
     B...(PROP(94)).. =,E14.6,/,
     C        1H ,4X,65HALGORITHM INDICATOR ............................
     D...(PROP(95)).. =,E14.6,/,
     E        1H ,4X,65HCONVERGENCE TOLERANCE ..........................
     F...(PROP(96)).. =,E14.6,/,
     G        1H ,4X,65HINELASTIC STRAIN TOLERANCE .....................
     H...(PROP(97)).. =,E14.6,//)
 2065 FORMAT (1H ,4X,92HWARNING   THE USE OF PROP(94) .LT. 6 CAN RESULT
     1IN A HIGHLY INACCURATE OR DIVERGENT SOLUTION)
 2071 FORMAT (6H PROP(,I2,1H,I2,3H) =,E15.6)
 2200 FORMAT (///38H E L E M E N T   I N F O R M A T I O N//
     1        39X,7HINITIAL/
     2        4X,1HN,3X,4HIELD,3X,3HIPS,2X,4HMTYP,4X,2HKG,
     3        9X,6HSTRAIN,6X,A6,6X,5HETIME,3X,6HINTLOC,13X,
     4        34HNODE(1)  NODE(2)  NODE(3)  NODE(4)/
     5        63X,11HINTEGRATION,20X,19HGLOBAL  COORDINATES/
     6        66X,5HPOINT,19X,1HX,12X,1HY,12X,1HZ)
 2208 FORMAT (1H ,64X,I4,15X,2(E11.4,2X),E11.4)
 2209 FORMAT (42H INTEGRATION POINT PRINTING NOT APPLICABLE   ,
     1        17H FOR RING ELEMENT   )
 2210 FORMAT (/I5,3I6,I7,5X,2(E11.4,2X),E11.4,1X,I3,15X,I4,3(5X,I4))
 2300 FORMAT (///16H ELEMENT GROUP =,I2,16H  (TRUSS / RUSS)/
     1        17H ELEMENT NUMBER =,I4/
     2        7H IELD =,I3,26H IS GREATER THAN NPAR(7) =,I3/
     3        5H STOP)
 2310 FORMAT (///16H ELEMENT GROUP =,I2,16H  (TRUSS / RUSS)/
     1        17H ELEMENT NUMBER =,I4/
     2        7H MTYP =,I3,27H IS GREATER THAN NPAR(16) =,I3/5H STOP)
 2315 FORMAT(///23H INPUT ERROR **********/
     1          19H SUBSTRUCTURE  NO =,I3/
     2          19H ELEMENT GROUP NO =,I3/
     3          31H FIRST ELEMENT NUMBER MUST BE 1)
 2400 FORMAT (///16H ELEMENT GROUP =,I2,16H  (TRUSS / RUSS)/
     1        19H ALTHOUGH NPAR(6) =,I2,22H, NONE OF THE ELEMENTS/
     2        49H IN THIS GROUP REFERS TO SKEW COORDINATE SYSTEMS./
     3        50H IT IS ADVISED THAT NPAR(6) BE SET TO ZERO TO SAVE,
     4        15H STORAGE SPACE.//
     5        39H THIS IS ONLY AN INFORMATIONAL MESSAGE.///)
 2410 FORMAT (///16H ELEMENT GROUP =,I2,16H  (TRUSS / RUSS)/
     1        16H ELEMENT NUMBER=,I4/10H NPAR(6) =,I2//
     2        53H SINCE NODES OF THIS ELEMENT REFER TO SKEW COORDINATE/
     3        37H SYSTEM(S), NPAR(6) MUST BE SET TO 1.//8H S T O P)
 2500 FORMAT (1H1,48HS T R E S S   C A L C U L A T I O N S   F O R     ,
     1        27HE L E M E N T   G R O U P  ,I5,14H  ( TRUSSES ) ///,4X,
     2        7HELEMENT,10H  LOCATION,8X,5HFORCE,12X,6HSTRESS,11X,
     3        6HSTRAIN,9X,11HTEMPERATURE,/)
 2510 FORMAT (I9,I10,3(2X,E15.6))
 2520 FORMAT (1H )
 2550 FORMAT (1H1,48HS T R E S S   C A L C U L A T I O N S   F O R     ,
     1        27HE L E M E N T  G R O U P  ,I5,14H  ( TRUSSES ) ,///,
     2        1X,7HELEMENT,2X,6HSTRESS,/,1X,7HNUM/IPT,3X,5HSTATE)
 2600 FORMAT (1H1,48HS T R E S S   C A L C U L A T I O N S   F O R     ,
     1        27HE L E M E N T   G R O U P  ,I5,14H  ( TRUSSES ) ///,4X,
     2        7HELEMENT,10H  LOCATION,5X,5HSTATE,8X,5HFORCE,10X,
     3        6HSTRESS,10X,6HSTRAIN,6X,14HPLASTIC STRAIN,/)
 2650 FORMAT (1H1,48HS T R E S S   C A L C U L A T I O N S   F O R     ,
     1        27HE L E M E N T   G R O U P  ,I5,14H  ( TRUSSES ) ///,4X,
     2        7HELEMENT,10H  LOCATION,8X,5HFORCE,12X,6HSTRESS,11X,
     3        6HSTRAIN,/)
 3000 FORMAT (//,38H    ERROR   INCORRECT CREEP LAW NUMBER,///)
 3001 FORMAT (//,43H    ERROR   INCORRECT INTEGRATION PARAMETER,///)
 3002 FORMAT (//,50H    ERROR   INCORRECT NUMBER OF TEMPERATURE POINTS,
     1        ///)
 3003 FORMAT(//,43H    ERROR   TEMPERATURE POINTS OUT OF ORDER,///)
 3401 FORMAT (//50H INPUT ERROR DETECTED IN (RUSS/TRUSS)              //
     1          19H ELEMENT GROUP NO =,I5/
     2          27H MATERIAL PROPERTY SET NO =,I5/
     2          38H ZERO OR NEGATIVE INITIAL YIELD STRESS  //)
 3402 FORMAT (//50H INPUT ERROR DETECTED IN (RUSS/TRUSS)              //
     1          19H ELEMENT GROUP NO =,I5/
     2          27H MATERIAL PROPERTY SET NO =,I5/
     3          44H HARDENING MODULUS (ET) GREATER OR EQUAL TO   ,
     4          44H YOUNG*S MODULUS (E) IS NOT ALLOWED           //)
 3403 FORMAT (//33H ERROR IN MATERIAL PROPERTY INPUT //
     5          15H *** STOP ***         //)
C
      END
C *CDC* *DECK ELPAL1
C *UNI* )FOR,IS N.ELPAL1, R.ELPAL1
C
      SUBROUTINE ELPAL1 (NEL,AREA,PROP,WA,IPT,EPST,ENEW,SIG,PF)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO EVALUATE STRESSES FOR ELASTIC-PLASTIC MODELS OF TRUSS  .
C .         ELEMENT (MODELS 4 AND 5)                                  .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      COMMON /EL    / IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1                ISTAT,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
C
      DIMENSION STATE(2)
      DIMENSION PROP(1),WA(1)
C
      EQUIVALENCE (NPAR(15),MODEL)
C
      DATA STATE / 2H E, 2H*P /
C
C
      IF (MODEL-5) 300,600,900
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  4                                                 .
C .   ELASTIC - PLASTIC WITH ISOTROPIC HARDENING                      .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  300 E=PROP(1)
      ET=PROP(3)
C
      IST=2*IPT - 1
      YLD=WA(IST)
      PLST=WA(IST+1)
C
      YLDEPS=YLD/E
      TENEPS=PLST + YLDEPS
      IF (EPST.GT.TENEPS) GO TO 330
      COMEPS=PLST - YLDEPS
      IF (EPST.LT.COMEPS) GO TO 340
C
C
C     ELEMENT IS ELASTIC
C
      SIG=E * (EPST-PLST)
      ENEW=E
      IPEL=1
      GO TO 360
C
C
C     ELEMENT IS PLASTIC  (TENSION)
C
  330 SIG=YLD + ET*(EPST-TENEPS)
      YLD=SIG
      GO TO 350
C
C
C     ELEMENT IS PLASTIC  (COMPRESSION)
C
  340 SIG=-YLD + ET*(EPST-COMEPS)
      YLD=-SIG
C
  350 PLST=EPST - (SIG/E)
      ENEW=ET
      IF (IEQREF.EQ.1) ENEW=E
      IPEL=2
C
C
  360 PF=AREA*SIG
      IF (KPRI.NE.0) GO TO 380
      IF (IPRI.EQ.0) WRITE (6,2000) NEL,IPT,STATE(IPEL),PF,SIG,EPST,PLST
      RETURN
C
  380 IF (IUPDT.EQ.1) RETURN
      WA(IST)=YLD
      WA(IST+1)=PLST
      RETURN
C
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  5                                                 .
C .   ELASTIC - PLASTIC WITH KINEMATIC HARDENING                      .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  600 E=PROP(1)
      YLD=PROP(2)
      ET=PROP(3)
C
      IST=2*IPT - 1
      TENYLD=WA(IST)
      PLST=WA(IST+1)
C
      TENEPS=(TENYLD/E) + PLST
      IF (EPST.GT.TENEPS) GO TO 630
      COMYLD=TENYLD - (2.*YLD)
      COMEPS=(COMYLD/E) + PLST
      IF (EPST.LT.COMEPS) GO TO 640
C
C
C     ELEMENT IS ELASTIC
C
      SIG=E * (EPST-PLST)
      ENEW=E
      IPEL=1
      GO TO 660
C
C     ELEMENT IS PLASTIC  (TENSION)
C
  630 SIG=TENYLD + ET*(EPST-TENEPS)
      TENYLD=SIG
      GO TO 650
C
C
C     ELEMENT IS PLASTIC  (COMPRESSION)
C
  640 SIG=COMYLD + ET*(EPST-COMEPS)
      TENYLD=SIG + (2.*YLD)
C
  650 PLST=EPST - (SIG/E)
      ENEW=ET
      IF (IEQREF.EQ.1) ENEW=E
      IPEL=2
C
C
  660 PF=AREA*SIG
      IF (KPRI.NE.0) GO TO 680
      IF (IPRI.EQ.0) WRITE (6,2000) NEL,IPT,STATE(IPEL),PF,SIG,EPST,PLST
      RETURN
C
  680 IF (IUPDT.EQ.1) RETURN
      WA(IST)=TENYLD
      WA(IST+1)=PLST
      RETURN
C
C
C
  900 STOP
C
C
 2000 FORMAT (I9,I10,4X,A2,6HLASTIC,4(2X,E14.6))
C
C
      END
C *CDC* *DECK LENTH1
C *UNI* )FOR,IS N.LENTH1,R.LENTH1
      SUBROUTINE LENTH1 (XYZ,RL)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO CALCULATE THE ARCLENGTH FOR VARIABLE NODE TRUSS        .
C .         ELEMENT                                                   .
C .                                                                   .
C .         RL(I) IS THE ARCLENGTH FROM NODE 1 TO NODE (I+1)          .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C     INTEG = NO OF INTEGRATION POINTS USED IN CALCULATING ARCLENGTH
C             BETWEEN ARCLENGTH NODES (MAX=4 - SEE COMMON /GAUSS/ )
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TRNODE/ IELD,IDIM,RST(12),DISP(12),PP(4),STS(4),STN(4),
     1                ARL(4)
      COMMON /GAUSS / XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION XYZ(1),RL(1)
      DIMENSION INTEGS(4),HR(4)
C
      DATA INTEGS /0,1,2,3/
C
C
      INTEG=INTEGS(IELD)
      ARC=2./DBLE(FLOAT(IELD-1))
      BETA=ARC/2.
      ALFA=-(1.+BETA)
C
C
      RL(1)=0.
      DO 100 N=2,IELD
      RL(N)=0.
      ALFA=ALFA+ARC
      DO 90 I=1,INTEG
      R=ALFA + BETA*XG(I,INTEG)
      FACT=BETA*WGT(I,INTEG)
      CALL FUNCT1 (ADUM,HR,R,IELD,0,1)
      DUM=0.
      DO 75 J=1,3
      TEMP=0.
      KK=J-3
      DO 60 K=1,IELD
      KK=KK+3
   60 TEMP=TEMP + HR(K)*XYZ(KK)
C
   75 DUM=DUM + TEMP*TEMP
      TEMP=DSQRT(DUM)
C
   90 RL(N)=RL(N) + FACT*TEMP
C
  100 CONTINUE
C
C
      DO 125 N=2,IELD
  125 RL(N)=RL(N) + RL(N-1)
      RL(1)=RL(IELD)
C
      RETURN
C
C
      END
C *CDC* *DECK FUNCT1
C *UNI* )FOR,IS N.FUNCT1,R.FUNCT1
      SUBROUTINE FUNCT1 (H,HR,R,IELD,IH,IHR)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO CALCULATE INTERPOLATION FUNCTIONS, AND THEIR           .
C .         DERIVATIVES FOR VARIABLE NODE TRUSS ELEMENT               .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION H(1),HR(1)
C
C
      GO TO (10,20,30,40), IELD
C
   10 RETURN
C
C
   20 IF (IH.EQ.0) GO TO 24
      H(1)=.5*(1-R)
      H(2)=.5*(1+R)
   23 IF (IHR.EQ.0) RETURN
   24 HR(1)=-.5
      HR(2)= .5
C
      RETURN
C
C
C
   30 IF (IH.EQ.0) GO TO 34
C
      RR=R*R
      H(1)=(-.5)*(R-RR)
      H(2)=( .5)*(R+RR)
      H(3)=(1.-RR)
C
   33 IF (IHR.EQ.0) RETURN
C
   34 HR(1)=(-.5)+R
      HR(2)=( .5)+R
      HR(3)=(-2.)*R
C
      RETURN
C
C
   40 TR=3.*R
      R1=TR+3.
      R2=TR-3.
      R3=TR+1.
      R4=TR-1.
C
      IF (IH.EQ.0) GO TO 44
C
      H(1)=(R2*R3*R4) / (-48.)
      H(2)=(R1*R3*R4) / ( 48.)
      H(3)=(R1*R2*R4) / ( 16.)
      H(4)=(R1*R2*R3) / (-16.)
C
   43 IF (IHR.EQ.0) RETURN
C
   44 HR(1)=(-.0625) * (R3*R4 + R2*R4 + R2*R3)
      HR(2)=( .0625) * (R3*R4 + R1*R4 + R1*R3)
      HR(3)=( .1875) * (R2*R4 + R1*R4 + R1*R2)
      HR(4)=(-.1875) * (R2*R3 + R1*R3 + R1*R2)
C
      RETURN
C
C
      END
C *CDC* *DECK STIF1
C *UNI* )FOR,IS N.STIF1,R.STIF1
      SUBROUTINE STIF1 (XYZ,AE,S)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO CALCULATE LINEAR ELASTIC STIFFNESS MATRIX OF           .
C .         2 TO 4 NODE TRUSS ELEMENT IN THE GLOBAL COORDINATES       .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /TRNODE/ IELD,IDIM,RST(12),DISP(12),PP(4),STS(4),STN(4),
     1                RL(4)
      COMMON /EL    / IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,
     1                IDAMP,ISTAT,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /GAUSS / XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION XYZ(1),S(1)
      DIMENSION B(12)
C
      EQUIVALENCE (NPAR(10),NINT)
C
C
      IDUM=IDIM*(IDIM+1)/2
      DO 110 I=1,IDUM
  110 S(I)=0.
C
C
C
      DO 200 IPT=1,NINT
C
      R=XG(IPT,NINT)
      CALL DERIQ1 (XYZ,R,B,XJ)
      FACT=AE*XJ*WGT(IPT,NINT)
C
      K=0
      DO 160 I=1,IDIM
      DUM=B(I)*FACT
      DO 160 J=I,IDIM
      K=K+1
      S(K)=S(K) + DUM*B(J)
  160 CONTINUE
C
  200 CONTINUE
C
      RETURN
C
C
      END
C *CDC* *DECK DERIQ1
C *UNI* )FOR,IS N.DERIQ1,R.DERIQ1
      SUBROUTINE DERIQ1 (XYZ,R,B,SR)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO CALCULATE STRAIN-DISPLACEMENT MATRIX                   .
C .         FOR MULTI-NODED TRUSS ELEMENTS                            .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TRNODE/ IELD,IDIM,RST(12),DISP(12),PP(4),STS(4),STN(4),
     1                RL(4)
C
      DIMENSION XYZ(1),B(1)
      DIMENSION HR(4)
C
C
      XR=0.
      YR=0.
      ZR=0.
C
      CALL FUNCT1 (H,HR,R,IELD,0,1)
C
C
C     CALCULATION OF XR=(DX/DR)
C
      DO 100 I=1,IELD
      K=3*(I-1)
      DUM=HR(I)
      XR=XR + DUM*XYZ(K+1)
      YR=YR + DUM*XYZ(K+2)
      ZR=ZR + DUM*XYZ(K+3)
C
  100 CONTINUE
C
C
C     CALCULATE SR=(DS/DR)
C
      SR=0.
      DO 200 I=2,IELD
  200 SR=SR + HR(I)*RL(I-1)
C
      RS=1./SR
C
      DUM=RS*RS
      XS=XR*DUM
      YS=YR*DUM
      ZS=ZR*DUM
C
C     CALCULATE THE B-MATRIX
C
      DO 300 I=1,IELD
      K=3*(I-1)
      DUM=HR(I)
      B(K+1)=XS*DUM
      B(K+2)=YS*DUM
      B(K+3)=ZS*DUM
  300 CONTINUE
C
C
      RETURN
C
      END
C *CDC* *DECK MASBAR
C *UNI* )FOR,IS N.MASBAR,R.MASBAR
      SUBROUTINE MASBAR (XYZ,ADEN,S)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       . TO CALCULATE THE CONSISTENT MASS MATRIX FOR               .
C .         VARIABLE NODE TRUSS ELEMENT                               .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TRNODE/ IELD,IDIM,RST(12),DISP(12),PP(4),STS(4),STN(4),
     1                RL(4)
      COMMON /GAUSS / XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION XYZ(1),S(1)
      DIMENSION MINTEG(4),H(4),HR(4)
C
      DATA MINTEG /0,2,4,4/
C
C
      IDUM=IDIM*(IDIM+1)/2
      DO 210 I=1,IDUM
  210 S(I)=0.
C
      INTEG=MINTEG(IELD)
C
      DO 250 I=1,INTEG
      R=XG(I,INTEG)
      CALL FUNCT1 (H,HR,R,IELD,1,1)
C
      XJ=0.
      DO 220 J=2,IELD
  220 XJ=XJ + HR(J)*RL(J-1)
C
      FACT=XJ*ADEN*WGT(I,INTEG)
C
      IDUM=IDIM
      JF=1
      DO 240 J=1,IELD
C
      JK=JF
      ADUM=H(J)*FACT
      DO 225 K=J,IELD
      S(JK)=S(JK) + ADUM*H(K)
      JK=JK + 3
  225 CONTINUE
C
      JF=JF + 3*(IDUM-1)
      IDUM=IDUM-3
C
  240 CONTINUE
C
  250 CONTINUE
C
C
      IDUM=IDIM
      JF=1
      DO 275 J=1,IELD
C
      JK=JF
      DO 260 K=J,IELD
      I=JK+IDUM
      S(I)=S(JK)
      I=I + (IDUM-1)
      S(I)=S(JK)
      JK=JK+3
  260 CONTINUE
C
      JF=JF + 3*(IDUM-1)
      IDUM=IDUM-3
C
  275 CONTINUE
C
      RETURN
C
C
      END
C *CDC* *DECK STIFN1
C
C *UNI* )FOR,IS N.STIFN1,R.STIFN1
C
C
      SUBROUTINE STIFN1 (NEL,AREA,PROP,WA,NODGL,TEMPV1,TEMPV2,
     1                   EPSI,S,RE,ISTIF,IPS)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .       . TO EVALUATE TRUSS ELEMENT STIFFNESS MATRIX                .
C .         IN NONLINEAR ANALYSIS (INDNL= 1 OR 2)                     .
C .                                                                   .
C .   MATERIAL SUBROUTINES SHOULD -                                   .
C .                                                                   .
C .       1.CALCULATE AND RETURN STRESS (SIG) AND FORCE (PF)          .
C .       2.PRINT STRESSES IF KPRI.EQ.0                               .
C .       3.IF KPRI.NE.0, AND ISTIF.EQ.1, CALCULATE AND RETURN        .
C .         CURRENT YOUNG*S MODULUS (E)                               .
C .       4.IF KPRI.NE.0, AND IUPDT.EQ.0, UPDATE WA,IWA               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /TRNODE/ IELD,IDIM,XYZ(12),DISP(12),PP(4),STS(4),STN(4),
     1                RL(4)
C
      DIMENSION PROP(1),WA(1),NODGL(1),TEMPV1(1),TEMPV2(1),S(1),RE(1)
      DIMENSION B(12),H(4),HR(4)
      DIMENSION RLT(4),RST(12)
C
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(15),MODEL),(NPAR(5),ITYPT),
     1            (NPAR(10),NINT),(NPAR(17),NCON)
C
      IF (ITYPT.EQ.1) GO TO 60
      CALL LENTH1 (XYZ,RL)
      IF (INDNL.NE.2) GO TO 60
      DO 50 I=1,IDIM
   50 RST(I)=XYZ(I)+DISP(I)
      CALL LENTH1 (RST,RLT)
   60 CONTINUE
C
      IF (KPRI.EQ.0) GO TO 125
C
      DO 110 I=1,IDIM
  110 RE(I)=0.
C
      IF (ISTIF.EQ.0) GO TO 125
C
      IDUM=IDIM*(IDIM+1)/2
      DO 120 I=1,IDUM
  120 S(I)=0.
C
C
  125 DO 400 IPT=1,NINT
C
      IF (ITYPT.NE.1) GO TO 140
      EPST=EPSI + (DISP(1)/XYZ(1))
      GO TO 225
C
C        A. FIND THE STRAINS
C
  140 R=XG(IPT,NINT)
      CALL FUNCT1 (H,HR,R,IELD,0,1)
C
      XR=0.
      YR=0.
      ZR=0.
C
      K=1
      DO 150 I=1,IELD
      HRI=HR(I)
      XR=XR + HRI*XYZ(K  )
      YR=YR + HRI*XYZ(K+1)
      ZR=ZR + HRI*XYZ(K+2)
      K=K+3
  150 CONTINUE
C
      SRZERO=0.
      DO 155 I=2,IELD
  155 SRZERO=SRZERO + HR(I)*RL(I-1)
      IF (INDNL.EQ.2) GO TO 175
C
C        A.1. MATERIALLY NONLINEAR FORMULATION
C
      XJ=SRZERO
C
      DUM=1./(XJ**2)
      XS=XR*DUM
      YS=YR*DUM
      ZS=ZR*DUM
C
C     CALCULATE THE B-MATRIX
C
      K=1
      DO 160 I=1,IELD
      HRI=HR(I)
      B(K  )=XS*HRI
      B(K+1)=YS*HRI
      B(K+2)=ZS*HRI
      K=K+3
  160 CONTINUE
C
C     CALCULATE STRAINS
C
      EPST=EPSI
      DO 170 I=1,IDIM
  170 EPST=EPST + B(I)*DISP(I)
      GO TO 225
C
C
C        A.2. UPDATED LAGRANGIAN FORMULATION
C
  175 XRT=XR
      YRT=YR
      ZRT=ZR
C
      K=1
      DO 180 I=1,IELD
      HRI=HR(I)
      XRT=XRT + HRI*DISP(K  )
      YRT=YRT + HRI*DISP(K+1)
      ZRT=ZRT + HRI*DISP(K+2)
  180 K=K+3
C
      XJ=0.
      DO 185 I=2,IELD
  185 XJ=XJ + HR(I)*RLT(I-1)
C
      EPST=EPSI + (XJ/SRZERO - 1.)
C
      IF (KPRI.EQ.0) GO TO 225
C
      DUM=1./(XJ**2)
      XS=XRT*DUM
      YS=YRT*DUM
      ZS=ZRT*DUM
C
C     CALCULATE THE B-MATRIX
C
      K=1
      DO 190 I=1,IELD
      HRI=HR(I)
      B(K  )=XS*HRI
      B(K+1)=YS*HRI
      B(K+2)=ZS*HRI
      K=K+3
  190 CONTINUE
C
C
C        B. CALCULATE STRESSES
C
  225 GO TO(230,240,260,270,270,280,280,290), MODEL
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  1   ( LINEAR ELASTIC )                            .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  230 E=PROP(1)
      SIG=E*EPST
      PF=AREA*SIG
      IF (KPRI.NE.0) GO TO 300
      IF (IPRI.EQ.0) WRITE (6,2100) NEL,IPT,PF,SIG,EPST
      GO TO 375
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  2   ( NONLINEAR ELASTIC )                         .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  240 IF (EPST.GE.PROP(1)) GO TO 245
      WRITE (6,2200) NG,NEL,KSTEP,ITE,MODEL,EPST,PROP(1)
      STOP
C
  245 IP=NCON/2
      DO 250 I=2,IP
      L=I
      IF (EPST.LE.PROP(I)) GO TO 255
  250 CONTINUE
C
      WRITE (6,2210) NG,NEL,KSTEP,ITE,MODEL,EPST,IP,PROP(IP)
      STOP
C
  255 DE=PROP(L) - PROP(L-1)
      LL=L + IP
      DS=PROP(LL) - PROP(LL-1)
      E=DS/DE
      SIG=PROP(LL-1) + E*(EPST-PROP(L-1))
      PF=AREA*SIG
      IF (KPRI.NE.0) GO TO 300
      IF (IPRI.EQ.0) WRITE (6,2100) NEL,IPT,PF,SIG,EPST
      GO TO 375
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  3   ( THERMOELASTIC )                             .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  260 CALL FUNCT1 (H,HR,R,IELD,1,0)
      CALL MTBTHE (PROP,AREA,EPST,PF,SIG,TEMPV1,TEMPV2,NODGL,
     1             H,IELD,E,NEL,IPT)
      IF (KPRI) 300,375,300
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L  =  4  AND  5   ( ELASTIC-PLASTIC )                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  270 CALL ELPAL1 (NEL,AREA,PROP,WA,IPT,EPST,E,SIG,PF)
      IF (KPRI) 300,375,300
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C     M O D E L = 6  AND  7   (ELASTIC-PLASTIC AND CREEP)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  280 CALL FUNCT1 (H,HR,R,IELD,1,0)
      CALL MTBEPC (WA,WA,PROP,AREA,EPST,PF,SIG,TEMPV1,TEMPV2,NODGL,
     1             H,IELD,E,NEL,IPT,IPS)
      IF (KPRI) 300,375,300
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C     M O D E L = 8  (USER SUPPLIED MODEL)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C 290 CALL TUSMOD
C     IF(KPRI) 300,375,300
  290 RETURN
C
C
C        C. CALCULATE NODAL FORCES
C
  300 IF (ITYPT.NE.1) GO TO 305
      RE(1)=PF
      IF (ISTIF.EQ.0) GO TO 400
      S(1)=AREA*E/(XYZ(1)+DISP(1))
      GO TO 400
C
  305 FACT=PF*XJ*WGT(IPT,NINT)
      DO 310 I=1,IDIM
  310 RE(I)=RE(I) + FACT*B(I)
C
      IF (ISTIF.EQ.0) GO TO 400
C
C        D. CALCULATE STIFFNESS MATRIX
C
C        D.1. MATERIAL STIFFNESS MATRIX
C
      FACT=AREA*E*XJ*WGT(IPT,NINT)
C
      L=0
      DO 340 I=1,IDIM
      DUM=FACT*B(I)
      DO 340 J=I,IDIM
      L=L+1
      S(L)=S(L) + DUM*B(J)
  340 CONTINUE
C
      IF (INDNL.NE.2) GO TO 400
C
C        D.2. GEOMETRIC STIFFNESS MATRIX
C
      FACT=PF*WGT(IPT,NINT)/XJ
C
      IDUM=IDIM
      JF=1
      DO 360 J=1,IELD
      JK=JF
      DUM=FACT*HR(J)
      DO 350 K=J,IELD
      ADUM=DUM*HR(K)
      S(JK)=S(JK) + ADUM
      L=JK + IDUM
      S(L)=S(L) + ADUM
      L=L + (IDUM-1)
      S(L)=S(L) + ADUM
      JK=JK+3
  350 CONTINUE
C
      JF=JF + 3*(IDUM-1)
      IDUM=IDUM-3
C
  360 CONTINUE
C
      GO TO 400
C
C
  375 STN(IPT)=EPST
      STS(IPT)=SIG
      PP (IPT)=PF
C
C
  400 CONTINUE
C
C
      RETURN
C
C
 2100 FORMAT (I9,I10,3(2X,E15.6))
 2200 FORMAT (///25H ERROR IN ELEMENT GROUP =,I3,19H   (TRUSS / STIFN1)/
     1        17H ELEMENT NUMBER =,I5//
     1        5X,12H TIMESTEP  =,I5 / 5X,12H ITERATION =,I5 //
     2        5X,17H MATERIAL MODEL =,I5 / 5X, 9H STRAIN =,E12.6,
     3        23H IS LESS THAN PROP(1) =,E12.6 //  5H STOP)
 2210 FORMAT (///25H ERROR IN ELEMENT GROUP =,I3,19H   (TRUSS / STIFN1)/
     1        17H ELEMENT NUMBER =,I5//
     1        5X,12H TIMESTEP  =,I5 / 5X,12H ITERATION =,I5 //
     2        5X,17H MATERIAL MODEL =,I5 / 5X, 9H STRAIN =,E12.6,
     3        22H IS GREATER THAN PROP(,I2,3H) =,E12.6 // 5H STOP)
C
      END
C *CDC* *DECK IMATB
C *UNI* )FOR,IS N.IMATB,R.IMATB
      SUBROUTINE IMATB(PROP,WA,IWA,NODGL,TEMPV1,NODE,IELD)
C
C
C     THIS SUBROUTINE INITIALIZES THE WORKING STORAGE FOR TRUSS
C     MATERIAL MODELS  3-7
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DPR/ ITWO
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1                TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2                SUBDD,RNGL,RNGU,DTT,TOL7,
     3                KCRP,NITE,NALG,IINTP,NPTS,ITCHK
C
      DIMENSION PROP(1),WA(1),IWA(1),NODGL(1),TEMPV1(1),NODE(1)
C
      DIMENSION H(4),PROP1(4)
C
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(10),NINT),(NPAR(5),ITYPT)
C
C
      IMOD=MODEL-2
      GO TO(30,40,40,50,50,70), IMOD
C
C     THERMOELASTIC
C
C        STORE GLOBAL NODAL POINT NUMBERS IN NODGL ARRAY
C
   30 DO 35 K=1,IELD
      NODGL(K)=NODE(K)
   35 CONTINUE
      RETURN
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   M O D E L S   4  AND  5                                         .
C .   ELASTIC - PLASTIC WITH ISOTROPIC / KINEMATIC HARDENING          .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C     WA(IST  )= YIELD IN TENSION
C     WA(IST+1)= PLASTIC STRAIN
C
   40 DO 45 K=1,NINT
      IST=2*(K-1) + 1
      WA(IST  )=PROP(2)
      WA(IST+1)=0.
   45 CONTINUE
      RETURN
C
C
C     THERMO-ELASTIC-PLASTIC AND CREEP
C
   50 NPTS=IDINT(PROP(89))
      TOLMT=1.0D-2
C
      TOLL=TOLMT*DABS(PROP(1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1) - TOLL
      RNGU=PROP(NPTS) + TOLU
C
C        STORE GLOBAL NODAL POINT NUMBERS IN NODGL ARRAY
C
      DO 55 K=1,IELD
      NODGL(K)=NODE(K)
   55 CONTINUE
C
C        LOOP OVER ALL INTEGRATION POINTS
C
      DO 100 KK=1,NINT
      IST=12*(KK - 1) + 1
      IST1=IST + 9
      IST2=IST + 4
C
C        SET ALL FLOATING POINT VARIABLES IN THE WORKING ARRAY
C        TO ZERO
C
      DO 60 K=IST,IST1
   60 WA(K)=0.0
C
C        INTERPOLATE INITIAL TEMPERATURE DISTRIBUTION
C
      IF(ITYPT.EQ.0) GO TO 63
      JJ=NODGL(1)
      WA(IST1)=TEMPV1(JJ)
      GO TO 66
C
   63 R=XG(KK,NINT)
      CALL FUNCT1 (H,HR,R,IELD,1,0)
      TEMP1=0.0
C
      DO 64 J=1,IELD
      JJ=NODGL(J)
   64 TEMP1=TEMP1 + H(J)*TEMPV1(JJ)
C
C
C        INITIALIZE AND STORE YIELD STRESS
C
      CALL MTITP1(PROP,TEMP1,PROP1)
      YS1=PROP1(2)
      WA(IST2)=YS1
      WA(IST1)=TEMP1
C
C        INITIALIZE INTEGER VARIABLES IN THE WORKING ARRAY TO 1
C
   66 IST=(12*KK - 2)*ITWO + 1
      IST1=IST+ITWO
      IWA(IST)=1
      IWA(IST1)=1
  100 CONTINUE
C
      RETURN
C
C
C     USER MODEL  (MODEL 8)
C
   70 WRITE (6,2000) MODEL
      STOP
C
C
 2000 FORMAT (//23H TRUSS MATERIAL MODEL =,I3,10X,17H( TRUSS / IMATB )/,
     1        46H USER SHOULD PROVIDE AN INITIALIZATION ROUTINE/
     2        //5H STOP)
C
      END
C *CDC* *DECK MTBTHE
C *UNI* )FOR,IS N.MTBTHE,R.MTBTHE
      SUBROUTINE MTBTHE(PROP,AREA,   EPST,PF,SIG,TEMPV1,TEMPV2,NODGL,H,
     1                  IELD,E,NEL,IPT)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
C
      DIMENSION PROP(16,1),TEMPV1(1),TEMPV2(1),NODGL(1),H(1),
     1          PROP1(2),PROP2(2),DTEMP(2)
C
      EQUIVALENCE (NPAR(15),MODEL), (NPAR(5),ITYPT)
C
C
C     THIS SUBROUTINE CALCULATES THE STRESSES AND STRESS-STRAIN LAW
C     FOR THE THERMOELASTIC MATERIAL MODEL  (MODEL = 3)
C
C
C
      IF(IPT.GT.1) GO TO 5
      NPTS=IDINT(PROP(1,4))
      TOLMT=1.0D-2
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C
C        1. INTERPOLATE NODAL POINT TEMPERATURES AT START AND END
C           OF CURRENT SOLUTION STEP
C
C     AXISYMMETRIC TRUSS **
C
    5 IF(ITYPT.EQ.0) GO TO 10
      KK=NODGL(1)
      TEMP1=TEMPV1(KK)
      TEMP2=TEMPV2(KK)
      GO TO 20
C
C     GENERAL TRUSS **
C
   10 TEMP1=0.0
      TEMP2=0.0
C
      DO 15 K=1,IELD
      KK=NODGL(K)
      TEMP1=TEMP1+H(K)*TEMPV1(KK)
   15 TEMP2=TEMP2+H(K)*TEMPV2(KK)
C
C        2. INTERPOLATE MATERIAL PROPERTY TABLES
C
   20 DTEMP(1)=TEMP1
      DTEMP(2)=TEMP2
C
      DO 75 J=1,2
      DTEM=DTEMP(J)
      IF(DTEM.GE.RNGL) GO TO 35
      WRITE(6,3001)
      STOP
C
   35 L=0
      DO 40 K=2,NPTS
      L=L+1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(DTEM.GT.DUM) GO TO 40
      GO TO 45
   40 CONTINUE
      WRITE(6,3001)
      STOP
C
   45 XRATIO=(DTEM-PROP(L,1))/(PROP(L+1,1)-PROP(L,1))
C
C     CORRECT XRATIO FOR THE CASE WHEN DTEM LIES OUTSIDE TABLE, BUT
C     WITHIN THE TOLERANCE RANGE **
C
      IF(XRATIO.GT.1.0) XRATIO=1.0
      IF(XRATIO.LT.0.0) XRATIO=0.0
      IF(J.EQ.2) GO TO 65
C
C     PROP1(I) CONTAINS MATERIAL PROPERTIES AT TEMP1 **
C     PROP2(I) CONTAINS MATERIAL PROPERTIES AT TEMP2 **
C
      DO 60 M=2,3
   60 PROP1(M-1)=PROP(L,M)+XRATIO*(PROP(L+1,M)-PROP(L,M))
      GO TO 75
   65 DO 70 M=2,3
   70 PROP2(M-1)=PROP(L,M)+XRATIO*(PROP(L+1,M)-PROP(L,M))
   75 CONTINUE
C
      E1=PROP1(1)
      ALPHA1=PROP1(2)
      E2=PROP2(1)
      ALPHA2=PROP2(2)
      TREF=PROP(2,4)
C
C        3. COMPUTE AXIAL STRESS AND FORCE
C
C     CHECK FOR START OF A SOLUTION STEP **
C     (ICOUNT .NE. 3 AND KPRI .NE. 0 INDICATE THE START OF A
C      SOLUTION STEP)
C
      IF(ICOUNT.NE.3.AND.KPRI.NE.0) GO TO 150
      EPSTH=ALPHA2*(TEMP2-TREF)
      SIG=E2*(EPST-EPSTH)
      PF=SIG*AREA
      IF (ICOUNT.EQ.3) RETURN
      IF(IPRI.EQ.0) WRITE(6,2100) NEL,IPT,PF,SIG,EPST,TEMP2
      RETURN
C
C     CALCULATE STRESS CONTRIBUTION TO  GEOMETRICALLY NONLINEAR
C     STIFFNESS MATRIX AND EFFECTIVE LOAD VECTOR **
C
  150 EPSTH=ALPHA1*(TEMP1-TREF)
      SIG=E1*(EPST-EPSTH)
      DEPSTH=ALPHA2*(TEMP2-TREF) - ALPHA1*(TEMP1-TREF)
      PF=(SIG-E2*DEPSTH)*AREA
      E=E2
      RETURN
C
 2100 FORMAT (I9,I10,4(2X,E15.6))
 3001 FORMAT(93H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PROPER
     1TY TEMPERATURES   (SUBROUTINE MTBTHE))
      END
C *CDC* *DECK MTBEPC
C *UNI* )FOR,IS N.MTBEPC,R.MTBEPC
C
      SUBROUTINE MTBEPC(WA,IWA,PROP,AREA,STRAIN,PF,STRESS,TEMPV1,
     1                  TEMPV2,NDS,H,IELD,CEP,NEL,IPT,IPS)
C
C
C
C     THIS SUBROUTINE CALCULATES THE STRESS, PLASTIC STRAIN,
C     CREEP STRAIN AND THE CONSTITUTIVE LAW FOR THE
C     THERMO-ELASTIC-PLASTIC AND CREEP MATERIAL MODELS
C     (MODELS = 6 AND 7)
C
C
C
C     NALG = 1  ALGORITHM USES ISUBM SUBDIVISIONS OF EQUAL SIZE
C
C          = 2  ALGORITHM USES VARIABLE SIZE SUBDIVISIONS UP TO A
C               MAXIMUM OF ISUBM
C
C
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        SIG = STRESS AT TIME OF LAST UPDATE
C        EPS = TOTAL STRAIN AT TIME OF LAST UPDATE
C        EPSP = PLASTIC STRAIN AT TIME OF LAST UPDATE
C        EPSC = CREEP STRAIN AT TIME OF LAST UPDATE
C        YLD = YIELD STRESS AT TIME OF LAST UPDATE
C        EPSTR = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT TIME OF LAST
C                UPDATE
C        ALFA = YIELD SURFACE TRANSLATION AT TIME OF LAST UPDATE
C        IPEL = ELASTIC-PLASTIC INDICATOR AT TIME OF LAST UPDATE
C        NORG = CYCLIC CREEP ORIGIN INDICATOR AT TIME OF LAST UPDATE
C        TREF = REFERENCE TEMPERATURE
C        KCRP = CREEP LAW NUMBER
C        CRPCON = CREEP LAW COEFFICIENTS
C        XINTP = INTEGRATION PARAMETER
C        ISUBM = MAXIMUM NUMBER OF SUBDIVISIONS
C        NITE = MAXIMUM NUMBER OF ITERATIONS PER SUBDIVISION
C        NALG = ALGORITHM INDICATOR
C        TOLIL,TOL1 = CONVERGENCE TOLERANCES
C        TOL2,TOL5 = ZERO TOLERANCES
C        TOL3,TOL4 = ROUNDOFF TOLERANCES
C        TOL6,TOL7 = YIELD SURFACE TOLERANCES
C        TOLPC = INELASTIC STRAIN TOLERANCE
C        TOLMT = MATERIAL PROPERTY TABLE TEMPERATURE TOLERANCE
C        DTT = CURRENT TIME STEP
C        DTOD = OLD TIME STEP WHEN USING RESTART
C        DELT = TIME STEP SUBDIVISION
C        STRAIN = TOTAL STRAIN
C        STRESS=STRESS
C        DELEPS = INCREMENT IN TOTAL STRAIN
C        EPS1,EPS2 = TOTAL STRAIN AT START AND END OF SUBDIVISION
C        DEPS = CHANGE IN TOTAL STRAIN FOR THE SUBDIVISION
C        STRSS1,STRSS2 = STRESS AT START AND END OF SUBDIVISION
C        STRSSM = WEIGHTED STRESS
C        DELSIG = CHANGE IN STRESS FOR THE SUBDIVISION
C        EPST1,EPST2 = THERMAL STRAIN AT START AND END OF SUBDIVISION
C        THSTR1 = THERMAL STRAIN RATE AT START OF SUBDIVISION
C        DPST = CHANGE IN THERMAL STRAIN FOR THE SUBDIVISION
C        EPSC1,EPSC2 = CREEP STRAIN AT START AND END OF SUBDIVISION
C        EPSCM = WEIGHTED CREEP STRAIN
C        DPSC = CHANGE IN CREEP STRAIN FOR THE SUBDIVISION
C        EPSP1,EPSP2 = PLASTIC STRAIN AT START AND END OF SUBDIVISION
C        DPSP = CHANGE IN PLASTIC STRAIN FOR THE SUBDIVISION
C        EPSTR1,EPSTR2 = ACCUMULATED EFFECTIVE PLASTIC STRAIN AT START
C                        AND END OF SUBDIVISION
C        EPSTRM = WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C        TEMP1,TEMP2 = TEMPERATURES AT START AND END OF CURRENT
C                      SOLUTION STEP
C        TMP1,TMP2 = TEMPERATURES AT START AND END OF SUBDIVISION
C        TMPM = WEIGHTED TEMPERATURE
C        ALFA1,ALFA2 = YIELD SURFACE TRANSLATION AT START AND END OF
C                      SUBDIVISION
C        ALFAM = WEIGHTED YIELD SURFACE TRANSLATION
C        PROP1,PROP2 = MATERIAL PROPERTIES AT START AND END OF
C                      SUBDIVISION
C        PROPM = WEIGHTED MATERIAL PROPERTIES
C        YLD1,YLD2 = YIELD STRESS AT START AND END OF SUBDIVISION
C        YLDM = WEIGHTED YIELD STRESS
C        XLAMDA = LOADING/UNLOADING/NEUTRAL LOADING INDICATOR
C        NDS = ELEMENT GLOBAL NODAL POINT NUMBERS
C        PF = AXIAL FORCE
C        CEP = MATERIAL MODULUS
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /DPR/ ITWO
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
C
      DIMENSION WA(1),IWA(1),PROP(16,1),TEMPV1(1),TEMPV2(1),NDS(1),
     1          H(1),PROP1(4),PROPM(4),PROP2(4),ORIG(2),STATE(2)
C
      EQUIVALENCE (NPAR(5),ITYPT),(NPAR(15),MODEL)
C
      DATA STATE /2H E,2H*P/
C
C
C
C        1. INITIALIZE SOLUTION PARAMETERS
C
      INDEX=1
      ISUB=1
      ISUBM=IDINT(PROP(13,6))
C
      IF(IPT.GT.1) GO TO 10
C
C     SET TIME STEP SIZE **
C
      DTT=DT
      IF(MODEX.EQ.2.AND.KSTEP.EQ.1.AND.ICOUNT.NE.3.AND.
     1   KPRI.NE.0) DTT=DTOD
C
      SUBDD=5.0
      DTMN=DTT/PROP(13,6)
      IINTP=1
C
      DO 5 J=1,8
    5 CRPCON(J)=PROP(J,6)
C
      NPTS=IDINT(PROP(9,6))
      TREF=PROP(10,6)
      KCRP=IDINT(PROP(11,6))
      XINTP=PROP(12,6)
      NITE=IDINT(PROP(14,6))
      NALG=IDINT(PROP(15,6))
      TOLIL=PROP(16,6)
      TOLPC=PROP(1,7)
C
      XCON1=2.0/3.0
      XCON2=1.0/3.0
C
      ITCHK=1
      IF(NITE.LT.6) ITCHK=0
C
C     SET INTEGRATION PARAMETERS **
C
      XPARM1=1.0 - XINTP
      XPARM2=XINTP
C
C     SET TOLERANCES **
C
      TOL1=TOLIL*TOLIL
      TOL4=5.0D-6
      TOL5=1.0D-20
      TOL2=TOL5*TOL5
      TOL3=2.0*TOL4
      TOL6=0.1
      TOL7=2.0
      TOLMT=1.0D-2
      TCHK=DTT*(1.0 - TOL4)
C
      TOLL=TOLMT*DABS(PROP(1,1))
      IF(TOLL.EQ.0.0) TOLL=TOLMT
      TOLU=TOLMT*DABS(PROP(NPTS,1))
      IF(TOLU.EQ.0.0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C        2. INITIALIZE SOLUTION VARIABLES
C
   10 IWAD=12*(IPT - 1) + 1
      SIG=WA(IWAD)
      EPS=WA(IWAD + 1)
      EPSP=WA(IWAD + 2)
      EPSC=WA(IWAD + 3)
      YLD=WA(IWAD + 4)
      EPSTR=WA(IWAD + 5)
      ALFA=WA(IWAD + 6)
      ORIG(1)=WA(IWAD + 7)
      ORIG(2)=WA(IWAD + 8)
      TMPOLD=WA(IWAD + 9)
C
      IWAD=(12*IPT - 2)*ITWO + 1
      IPEL=IWA(IWAD)
      NORG=IWA(IWAD + ITWO)
C
      EPS1=EPS
      EPSP1=EPSP
      EPSP2=EPSP
      ALFA1=ALFA
      ALFA2=ALFA
      EPSC1=EPSC
      EPSC2=EPSC
      DPSC=0.0
      STRSS2=SIG
      STRSS1=SIG
C
      YLD1=YLD
      EPSTR1=EPSTR
      EPSTR2=EPSTR
      ECSTR1=0.0
      CRSRM=0.0
      TMP1=TMPOLD
      TAU=0.0
      ESTM=0.0
C
C        3. CALCULATE TOTAL STRAIN INCREMENT
C
      DELEPS=STRAIN - EPS
C
C        4. CALCULATE TEMPERATURE INCREMENT
C
C     CALCULATE INTEGRATION POINT TEMPERATURES **
C
      IF(ITYPT.EQ.0) GO TO 20
      KK=NDS(1)
      TEMP1=TEMPV1(KK)
      TEMP2=TEMPV2(KK)
      GO TO 35
C
   20 TEMP1=0.0
      TEMP2=0.0
C
      DO 30 K=1,IELD
      KK=NDS(K)
      TEMP2=TEMP2 + H(K)*TEMPV2(KK)
   30 TEMP1=TEMP1 + H(K)*TEMPV1(KK)
C
   35 CTEMP=TEMP2
C
C     CHECK FOR START OF A SOLUTION STEP *
C
      IF(ICOUNT.NE.3.AND.KPRI.NE.0) CTEMP=TEMP1
C
      DELTMP=CTEMP - TMPOLD
C
C        5. CALCULATE MATERIAL PROPERTIES AT TIME OF LAST UPDATE
C
      CALL MTITP1(PROP,TMPOLD,PROP1)
C
      YM1=PROP1(1)
      ET1=PROP1(3)
      YS1=PROP1(2)
C
      EET1=YM1*ET1/(YM1 - ET1)
C
C        6. CALCULATE SIZE OF FIRST SUBDIVISION
C           (STRESS LOOP NO. 1)
C
   40 DELT=DTMN
      IF(KCRP.EQ.0.AND.NALG.EQ.2) DELT=DTT
C
C        7. CALCULATE TOTAL STRAINS AT END OF SUBDIVISION
C
   60 XFAC=(TAU + DELT)/DTT
      EPS2=EPS + XFAC*DELEPS
      DEPS=EPS2 - EPS1
C
C        8. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C
      TMP2=TMPOLD + XFAC*DELTMP
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
      CALL MTITP1(PROP,TMP2,PROP2)
C
      YM2=PROP2(1)
C
C        9. CALCULATE THERMAL STRAIN AT END OF SUBDIVISION
C
      ALPHA2=PROP2(4)
      EPST2=ALPHA2*(TMP2 - TREF)
C
C        10. CALCULATE WEIGHTED STRESS
C
      IF(KCRP.EQ.0) GO TO 95
C
   70 STRSSM=XPARM1*STRSS1 + XPARM2*STRSS2
C
C        11. PRELIMINARY CREEP CALCULATIONS
C
      DPSC=0.0
      CRSRM=0.0
C
      ESTM=DABS(STRSSM)
      IF(ESTM.LE.TOL5.AND.INDEX.GT.1) GO TO 95
C
      EPSCM=XPARM1*EPSC1 + XPARM2*EPSC2
C
      CALL CREEP1(DELT,DPSC,TMPM,EPSCM,ORIG,NORG,STRSSM,GAMA,CRSRM,
     1            PTIME,ESTM,FF,RR,GG,INDEX,ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        12. CALCULATE THE STRESS AND CREEP STRAIN AT END OF
C             SUBDIVISION, ASSUMING THERMO-ELASTIC AND CREEP BEHAVIOR
C
   95 CALL SIGMA1(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,DELT,YM2)
C
C        13. CHECK FOR CONVERGENCE OF ITERATION
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ. 0),
C     WHEN KCRP .EQ. 0, OR WHEN XPARM2 .EQ. 0 **
C
  100 IF(KCRP.EQ.0) GO TO 215
      IF(XPARM2.EQ.0.0) GO TO 205
      IF(ITCHK.EQ.1) GO TO 120
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 70
      GO TO 205
C
C     CALCULATE THE NORM OF THE CHANGE IN THE CURRENT STRESS **
C
  120 IF(INDEX - 4) 122,135,125
C
  122 INDEX=INDEX + 1
      GO TO 70
C
  125 DNORM2=(STRSS2 - STRSSD)*(STRSS2 - STRSSD)
C
C     CALCULATE THE NORM OF THE CURRENT STRESS **
C
  135 SNORM=STRSS2*STRSS2
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 155
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      STRSSD=STRSS2
      GO TO 70
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  155 IF(DNORM2.LE.DNORM1) GO TO 185
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 205
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 170
C
      WRITE(6,3004)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET VARIABLES FOR NEW SUBDIVISION SIZE
C
  170 INDEX=1
      STRSS2=STRSS1
      EPSC2=EPSC1
C
      GO TO 60
C
C     FINAL CHECK FOR CONVERGENCE *
C
  185 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 205
C
C     NO CONVERGENCE
C
  190 INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 195
C
      WRITE(6,3001)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  195 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
      STRSSD=STRSS2
C
      GO TO 70
C
C        14. CHECK SIZE OF CREEP STRAIN INCREMENT

C     CHECK IS BYPASSED WHEN THE MODIFIED EFFECTIVE CREEP STRAIN AT
C     THE START OF THE SUBDIVISION AND/OR THE EFFECTIVE CREEP STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0, OR WHEN KCRP .EQ. 0 **
C
  205 DECSTR=CRSRM*DELT
      IF(DECSTR.LE.TOL5 .OR. ECSTR1.LE.TOL5) GO TO 215
C
      CHECK=DECSTR/(ECSTR1*TOLPC)
      IF(CHECK.LE.1.1) GO TO 215
C
C     CREEP STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 208
C
      WRITE(6,3006)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET VARIABLES FOR NEW SUBDIVISION SIZE **
C
  208 INDEX=1
      STRSS2=STRSS1
      EPSC2=EPSC1
C
      GO TO 60
C
C        15. CHECK FOR YIELDING
C
C     DETERMINE LOCATION OF THE STRESS-TEMPERATURE STATE AT END OF
C     SUBDIVISION WITH RESPECT TO THE YIELD SURFACE (ASSUMING NO
C     PLASTICITY) **
C
  215 DELSIG=STRSS2 - STRSS1
      EST2=DABS(STRSS2)
C
C     CALCULATE YIELD STRESS AT END OF SUBDIVISION *
C
      YM2=PROP2(1)
      ET2=PROP2(3)
      YS2=PROP2(2)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
      DYLD=YS2 - YS1
      IF(MODEL.EQ.6)  DYLD=DYLD + (EET2 - EET1)*EPSTR1
      YLD2=YLD1 + DYLD
C
  225 RA=DELSIG*DELSIG
      FTA=EST2
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.7) FTA=DABS(STRSS2 - 1.5*ALFA1)
C
C     CHECK FOR NO CHANGE IN THE STRESS-TEMPERATURE STATE *
C
      IF(RA.EQ.0.0 .AND. TMP1.EQ.TMP2) GO TO 228
C
      FTB=YLD2
      IF(FTA.GT.FTB) GO TO 250
C
C        16. STRESS STATE IS WITHIN THE YIELD SURFACE---
C            THERMO-ELASTIC/CREEP BEHAVIOR
C
      IPEL=1
  228 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 230
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 240
      GO TO 235
C
C    NALG .EQ. 2 *
C
  230 IF(TAU.GE.TCHK .OR. KCRP.EQ.0) GO TO 240
      IF(DECSTR.LE.TOL5) GO TO 232
C
      DELT=DELT*TOLPC*(1.0 + (ECSTR1/DECSTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 233
C
  232 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  233 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 235
C
      WRITE(6,3007)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  235 ISUB=ISUB + 1
      INDEX=1
      YS1=YS2
      EET1=EET2
      YLD1=YLD2
      TMP1=TMP2
C
      EPS1=EPS2
      STRSS1=STRSS2
      EPSC1=EPSC2
C
      GO TO 60
C
C     AT END OF TIME STEP, CALCULATE YIELD STRESS USING DEFINITION
C     BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE PLASTIC STRAIN **
C
  240 YLDC=YS2
      IF(MODEL.EQ.6) YLDC=EET2*EPSTR2 + YLDC
C
      GO TO 440
C
C        17. STRESS-TEMPERATURE STATE IS OUTSIDE THE YIELD
C            SURFACE---THERMO-ELASTIC-PLASTIC/CREEP BEHAVIOR
C
C            THERMO-ELASTIC-PLASTIC/CREEP STRESS CALCULATIONS
C            FOLLOW
C
C     CALCULATE THE FRACTION OF THE STRAIN SUBDIVISION OVER WHICH
C     THERE IS NO PLASTIC STRAINING **
C
  250 SX1=STRSS1
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.7) SX1=STRSS1 - 1.5*ALFA1
C
      RB=SX1*DELSIG
      RD=SX1*SX1
      RE=RB - YLD1*DYLD
      RF=RA - DYLD*DYLD
      RG=RD - YLD1*YLD1
C
      IF(IPEL.EQ.2.OR.RG.GE.0.0) GO TO 270
C
C     STRESS-TEMPERATURE STATE IS WITHIN THE YIELD SURFACE AT
C     START OF SUBDIVISION *
C
  260 IF(DABS(RF).GT.TOL5) GO TO 265
      RATIO=-RG/(2.0*RE)
      GO TO 275
C
  265 RATIO=(-RE + DABS(SX1*DYLD - YLD1*DELSIG))/RF
      GO TO 275
C
C     STRESS-TEMPERATURE STATE IS ON THE YIELD SURFACE AT START
C     OF SUBDIVISION *
C
  270 RATIO=0.0
      IF(RF.GT.TOL5.AND.RE.LT.0.0) RATIO=-2.0*RE/RF
C
C     CHECK CALCULATED VALUE OF RATIO **
C
  275 IF(RATIO.GE.(-TOL6) .AND. RATIO.LE.(1.0 + TOL6)) GO TO 280
C
      WRITE(6,3012)
      WRITE(6,3013) NEL,IPT,ISUB,TAU,IPEL,RA,RB,RD,RE,RF,RG,RATIO
      STOP
C
  280 IF(RATIO.GT.1.0) RATIO=1.0
      IF(RATIO.LT.0.0) RATIO=0.0
      IPEL=2
C
C        18. UPDATE ALL VARIABLES TO START OF YIELDING
C
      TAU=TAU + RATIO*DELT
      TMP1=TMPOLD + DELTMP*TAU/DTT
      YLD1=YLD1 + RATIO*DYLD
      IF(RATIO.GT.TOL5) ISUB=ISUB + 1
      IF(ISUB.GT.ISUBM) ISUBM=ISUBM + 1
C
C     CALCULATE STRESS, TOTAL STRAIN, AND CREEP STRAIN AT
C     START OF YIELDING **
C
      EPSC1=EPSC1 + RATIO*DPSC
      EPSC2=EPSC1
      STRSS1=STRSS1 + RATIO*DELSIG
      STRSS2=STRSS1
      EPS1=EPS1 + RATIO*DEPS
C
C     CALCULATE MATERIAL PROPERTIES AT START OF YIELDING **
C
  285 CALL MTITP1(PROP,TMP1,PROP1)
C
C     CALCULATE THERMAL STRAIN AT START OF YIELDING **
C
      ALPHA1=PROP1(4)
      EPST1=ALPHA1*(TMP1 - TREF)
C
C        19. CALCULATE SIZE OF FIRST SUBDIVISION AFTER YIELDING
C            (STRESS LOOP NO. 2)
C
  290 XNWDT=DTT - TAU
      DELT=XNWDT/DBLE(FLOAT(ISUBM - ISUB + 1))
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
C
C        20. CALCULATE TEMPERATURE AT END OF SUBDIVISION
C            AND WEIGHTED TEMPERATURE
C
  292 TMP2=TMPOLD + DELTMP*(TAU + DELT)/DTT
      TMPM=XPARM1*TMP1 + XPARM2*TMP2
C
C        21. CALCULATE MATERIAL PROPERTIES AT END OF SUBDIVISION
C            CALCULATE WEIGHTED MATERIAL PROPERTIES
C
      CALL MTITP1(PROP,TMP2,PROP2)
C
      DO 295 J=1,4
  295 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
      YM2=PROP2(1)
      YMM=PROPM(1)
      ETM=PROPM(3)
C
      EETM=YMM*ETM/(YMM - ETM)
      CEM=XCON1*EETM
C
C        22. CALCULATE THERMAL STRAIN AT END OF SUBDIVISION
C            AND THERMAL STRAIN CHANGE FOR THE SUBDIVISION
C
      ALPHA2=PROP2(4)
C
      EPST2=ALPHA2*(TMP2 - TREF)
      DPST=EPST2 - EPST1
C
C        23. CALCULATE TOTAL STRAIN AT END OF SUBDIVISION
C            AND TOTAL STRAIN CHANGE FOR THE SUBDIVISION
C
  300 XFAC=(TAU + DELT)/DTT
      EPS2=EPS + XFAC*DELEPS
      DEPS=EPS2 - EPS1
C
C        24. CALCULATE WEIGHTED STRESS
C
  310 STRSSM=XPARM1*STRSS1 + XPARM2*STRSS2
C
      ESTM=DABS(STRSSM)
C
C        25. CALCULATE WEIGHTED ACCUMULATED EFFECTIVE PLASTIC STRAIN
C
      EPSTRM=XPARM1*EPSTR1 + XPARM2*EPSTR2
C
C        26. CALCULATE WEIGHTED YIELD SURFACE TRANSLATION
C
      ALFAM=XPARM1*ALFA1 + XPARM2*ALFA2
C
C        27. CALCULATE WEIGHTED YIELD STRESS
C
      YLDM=ESTM
      IF(MODEL.EQ.7)  YLDM=DABS(STRSSM - 1.5*ALFAM)
C
C        28. PRELIMINARY CREEP CALCULATIONS
C
  328 IF(KCRP.EQ.0) GO TO 335
C
      DPSC=0.0
      CRSRM=0.0
C
      EPSCM=XPARM1*EPSC1 + XPARM2*EPSC2
C
      CALL CREEP1(DELT,DPSC,TMPM,EPSCM,ORIG,NORG,STRSSM,GAMA,CRSRM,
     1            PTIME,ESTM,FF,RR,GG,INDEX,ECSTRM)
C
      IF(INDEX.EQ.1) ECSTR1=ECSTRM
C
C        29. CALCULATE PLASTIC STRAIN AT END OF SUBDIVISION
C
  335 CALL EPMAT1(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,XLAMDA,PROP1,
     1            PROP2,PROPM,YLDM,1,DPSP,INDEX,EETM)
C
      EPSP2=EPSP1 + DPSP
C
C        30. CALCULATE ACCUMULATED EFFECTIVE PLASTIC STRAIN AT END
C            OF SUBDIVISION
C
      DEPSTR=DABS(DPSP)
      EPSTR2=EPSTR1 + DEPSTR
C
C        31. CALCULATE YIELD SURFACE TRANSLATION AT END
C            OF SUBDIVISION
C
      ALFA2=ALFA1 + CEM*DPSP
C
C        32. CALCULATE THE STRESS AND CREEP STRAIN AT END
C            OF SUBDIVISION
C
  345 CALL SIGMA1(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,PTIME,
     1            CRSRM,FF,RR,GG,ESTM,DELT,YM2)
C
C        33. CHECK FOR CONVERGENCE OF ITERATION
C
C     NO CONVERGENCE/DIVERGENCE CHECK WHEN NITE .LT. 6 (ITCHK .EQ. 0)
C     OR WHEN XPARM2 .EQ. 0.0 **
C
  350 IF(XPARM2.EQ.0.0) GO TO 400
      IF(ITCHK.EQ.1) GO TO 358
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 310
      GO TO 400
C
C     CALCULATE NORM OF THE CHANGE IN THE CURRENT STRESS **
C
  358 IF(INDEX - 4) 360,366,362
C
  360 INDEX=INDEX + 1
      GO TO 310
C
  362 DNORM2=(STRSS2 - STRSSD)*(STRSS2 - STRSSD)
C
C     CALCULATE NORM OF THE CURRENT STRESS **
C
  366 SNORM=STRSS2*STRSS2
C
C     VALUE OF INDEX .LE. 5 **
C
      IF(INDEX.GT.5) GO TO 375
      SNORM2=SNORM
      IF(INDEX.EQ.4) SNORM1=SNORM2
      IF(INDEX.EQ.5) DNORM1=DNORM2
      INDEX=INDEX + 1
C
      STRSSD=STRSS2
C
      GO TO 310
C
C     APPLY CONVERGENCE CRITERIA FOR INDEX .GE. 6 **
C
C     INITIAL CHECK FOR CONVERGENCE *
C
  375 IF(DNORM2.LE.DNORM1) GO TO 390
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND
C
      XTOL=TOL3*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL.AND.DNORM2.LE.XTOL) GO TO 400
C
C     DIVERGENCE IS INDICATED, CALCULATE NEW SUBDIVISION SIZE
C     (NALG .EQ. 2) *
C
      DELT=DELT*(DSQRT(DNORM1/DNORM2))/SUBDD
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 380
C
  378 WRITE(6,3008)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET VARIABLES FOR NEW SUBDIVISION SIZE
C
  380 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      STRSS2=STRSS1
      EPSP2=EPSP1
      ALFA2=ALFA1
      EPSC2=EPSC1
C
      GO TO 292
C
C     FINAL CHECK FOR CONVERGENCE *
C
  390 XTOL=TOL1*SNORM1
      IF(SNORM1.LE.TOL2) XTOL=TOL2
      IF(DNORM1.LE.XTOL) GO TO 400
C
C     NO CONVERGENCE
C
      INDEX=INDEX + 1
      IF(INDEX.LE.NITE) GO TO 395
C
      WRITE(6,3003)
      WRITE(6,3011) NEL,IPT,ISUB,TAU,DELT
      STOP
C
  395 DNORM1=DNORM2
      SNORM1=SNORM2
      SNORM2=SNORM
      STRSSD=STRSS2
C
      GO TO 310
C
C        34. CHECK SIZE OF INELASTIC STRAIN INCREMENT
C
C     CHECK IS BYPASSED WHEN THE EFFECTIVE INELASTIC STRAIN AT THE
C     START OF THE SUBDIVISION AND/OR THE EFFECTIVE INELASTIC STRAIN
C     RATE FOR THE SUBDIVISION .EQ. 0 **
C
  400 DECSTR=CRSRM*DELT
      DESTR=DECSTR + DEPSTR
      DENOM=ECSTR1 + EPSTR1
      IF(DESTR.LE.TOL5.OR.DENOM.LE.TOL5) GO TO 410
C
      CHECK=DESTR/(DENOM*TOLPC)
      IF(CHECK.LE.1.1) GO TO 410
C
C     INELASTIC STRAIN INCREMENT IS TOO LARGE, CALCULATE NEW
C     SUBDIVISION SIZE **
C
      DELT=DELT/CHECK
      IF(NALG.EQ.2.AND.ISUB.LT.ISUBM) GO TO 405
C
      WRITE(6,3009)
      WRITE(6,3002) NEL,IPT,ISUB,TAU,DELT
      STOP
C
C     RESET VARIABLES FOR NEW SUBDIVISION SIZE **
C
  405 INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      EPSTR2=EPSTR1
C
      STRSS2=STRSS1
      EPSP2=EPSP1
      ALFA2=ALFA1
      EPSC2=EPSC1
C
      GO TO 292
C
C        35. CALCULATE YIELD STRESS AT END OF SUBDIVISION
C
  410 ET2=PROP2(3)
      YS2=PROP2(2)
C
      EET2=YM2*ET2/(YM2 - ET2)
C
C     USING DEFINITION BASED ON TEMPERATURE AND ACCUMULATED EFFECTIVE
C     PLASTIC STRAIN **
C
C     KINEMATIC HARDENING *
C
      YLDC=YS2
C
C     ISOTROPIC HARDENING *
C
      IF(MODEL.EQ.6)  YLDC=EET2*EPSTR2 + YLDC
C
C     USING STRESS STATE **
C
      EST2=DABS(STRSS2)
C
C     ISOTROPIC HARDENING *
C
      YLD2=EST2
C
C     KINEMATIC HARDENING *
C
      IF(MODEL.EQ.7)  YLD2=DABS(STRSS2 - 1.5*ALFA2)
C
C        36. CORRECT STRESS STATE TO YIELD SURFACE
C
C     CHECK YIELD SURFACE ERROR **
C
  414 CHECK=DABS(YLD2 - YLDC)/DMIN1(YLD2,YLDC)
      IF(CHECK.LE.TOL7) GO TO 415
C
      WRITE(6,3014)
      WRITE(6,3015) NEL,IPT,ISUB,TAU,YLD2,YLDC
      STOP
C
C        37. UPDATE VARIABLES FOR NEXT SUBDIVISION
C
  415 TAU=TAU + DELT
C
C     CALCULATE SIZE OF NEXT SUBDIVISION **
C
      IF(NALG.EQ.2) GO TO 416
C
C     NALG .EQ. 1 *
C
      IF(ISUB.EQ.ISUBM) GO TO 440
      GO TO 425
C
C     NALG .EQ. 2 *
C
  416 IF(TAU.GE.TCHK) GO TO 440
      IF(DESTR.LE.TOL5) GO TO 420
C
      DELT=DELT*TOLPC*(1.0 + (DENOM/DESTR))
      IF(TAU + DELT.GE.TCHK) DELT=DTT - TAU
      GO TO 422
C
  420 DELT=DTT - TAU
C
C     IF NEXT SUBDIVISION IS THE LAST ONE, MAKE SURE DELT IS
C     LARGE ENOUGH
C
  422 IF(ISUB + 1.LT.ISUBM.OR.TAU + DELT.GE.TCHK) GO TO 425
C
      WRITE(6,3010)
      WRITE(6,3011) NEL,IPT,ISUBM,TAU,DELT
      STOP
C
C     UPDATE VARIABLES **
C
  425 ISUB=ISUB + 1
      INDEX=1
      DEPSTR=0.0
      DESTR=1.0
      DENOM=0.0
      TMP1=TMP2
      EPSTR1=EPSTR2
      EPST1=EPST2
C
      EPS1=EPS2
      STRSS1=STRSS2
      EPSC1=EPSC2
      ALFA1=ALFA2
      EPSP1=EPSP2
C
      DO 435 J=1,4
  435 PROP1(J)=PROP2(J)
C
      GO TO 292
C
C        38. PERMANENT UPDATING OF VARIABLES
C
  440 IF(IUPDT.NE.0) GO TO 455
C
      IWAD=12*(IPT - 1) + 1
      WA(IWAD)=STRSS2
      WA(IWAD + 1)=STRAIN
      WA(IWAD + 2)=EPSP2
      WA(IWAD + 3)=EPSC2
      WA(IWAD + 4)=YLD2
      WA(IWAD + 5)=EPSTR2
      WA(IWAD + 6)=ALFA2
      WA(IWAD + 7)=ORIG(1)
      WA(IWAD + 8)=ORIG(2)
      WA(IWAD + 9)=TMP2
C
      IWAD=(12*IPT - 2)*ITWO + 1
      IWA(IWAD)=IPEL
      IWA(IWAD + ITWO)=NORG
C
C        39. CALCULATE LATEST CONSTITUTIVE LAW
C
C     CHECK FOR EQUILIBRIUM ITERATION **
C
  455 STRESS=STRSS2
      PF=STRSS2*AREA
      IF(ICOUNT.EQ.3) RETURN
C
C     CHECK FOR PRINTING OF STRESSES **
C
      IF(KPRI.EQ.0) GO TO 600
C
C     UPDATE SOLUTION VARIABLES **
C
      EPSC1=EPSC2
      EPSP1=EPSP2
      EPST1=EPST2
      STRSS1=STRSS2
      ALFA1=ALFA2
      YLD1=YLD2
      EPSTR1=EPSTR2
      EST1=EST2
C
C     CALCULATE MATERIAL PROPERTIES AT END OF NEXT TIME STEP **
C
      DO 460 I=1,4
  460 PROP1(I)=PROP2(I)
C
      CALL MTITP1(PROP,TEMP2,PROP2)
      YM2=PROP2(1)
C
C     CALCULATE THERMAL STRAIN AT END OF NEXT TIME STEP **
C
      ALPHA2=PROP2(4)
      EPST2=ALPHA2*(TEMP2 - TREF)
      DPST=EPST2 - EPST1
C
C     ESTIMATE CREEP STRAIN AT END OF NEXT TIME STEP **
C
      INDEX=1
C
      IF(KCRP.EQ.0) GO TO 480
C
      DPSC=0.0
C
      IF(EST1.LE.TOL5) GO TO 480
      TMPM=XPARM1*TEMP1 + XPARM2*TEMP2
C
      CALL CREEP1(DT,DPSC,TMPM,EPSC1,ORIG,NORG,STRSS1,GAMA,CRSR1,
     1            PTIME,EST1,FF,RR,GG,INDEX,ECSTR1)
C
      EPSC2=EPSC1 + DPSC
C
C     CHECK ELASTIC-PLASTIC INDICATOR **
C
  480 IF(IPEL.EQ.2) GO TO 490
C
C     THERMO-ELASTIC AND CREEP BEHAVIOR **
C
      STRESS=YM2*(STRAIN - EPSP2 - EPSC2 - EPST2)
C
      PF=STRESS*AREA
      CEP=YM2
C
      RETURN
C
C     THERMO-ELASTIC-PLASTIC AND CREEP BEHAVIOR **
C
C
C     CALCULATE WEIGHTED MATERIAL PROPERTIES *
C
  490 DO 494 J=1,4
  494 PROPM(J)=XPARM1*PROP1(J) + XPARM2*PROP2(J)
C
C     ESTIMATE PLASTIC STRAIN AT END OF NEXT TIME STEP *
C
  500 YMM=PROPM(1)
      ETM=PROPM(3)
      EETM=YMM*ETM/(YMM - ETM)
C
      CALL EPMAT1(STRSS1,ALFA1,EPSTR1,DELEPS,DPSC,DPST,XLAMDA,PROP1,
     1            PROP2,PROPM,YLD1,2,DPSP,INDEX,EETM)
C
      EPSP2=EPSP1 + DPSP
C
      IF(IEQREF.EQ.1 .OR. XLAMDA.LT.0.0) GO TO 520
C
C     ITERATION WITH ELASTIC-PLASTIC STIFFNESS MATRIX *
C
      STRESS=-ETM*(DPSC + DPST) + YM2*(STRAIN - EPSP1 - EPSC1 -
     1       EPST1 - DPSP)
C
      PF=STRESS*AREA
      CEP=ETM
C
      RETURN
C
C     ITERATION WITH ELASTIC STIFFNESS MATRIX WHEN GLOBAL DIVERGENCE
C     PROCEDURE IS ACTIVATED OR UNLOADING IS DETECTED *
C
  520 STRESS=YM2*(STRAIN - EPSP2 - EPSC2 - EPST2)
C
      PF=STRESS*AREA
      CEP=YM2
C
      RETURN
C
C        40. PRINTING OF STRESSES
C
C     CALCULATE EFFECTIVE STRESS **
C
  600 FT=YLD2
      IF(IPEL.EQ.1) FT=FTA
C
  610 IF(IPRI.NE.0) RETURN
C
C     STRESS AND STRAIN PRINTOUT **
C
  700 IF(IPT.GT.1) GO TO 720
C
C     PRINT ELEMENT NUMBER *
C
      WRITE(6,2005) NEL
C
C     PRINT INTEGRATION POINT STRESS AND STRAINS *
C
  720 WRITE(6,2200) IPT,STATE(IPEL),PF,STRSS2,STRAIN,TEMP2,EPSTR2,ISUB
      WRITE(6,2400) EPSP2,EPSC2,EPST2,FT,YLD2,YLDC
C
      RETURN
C
 2005 FORMAT (/,1X,I3)
 2200 FORMAT (/,6X,I2,2X,A2,6HLASTIC,6X,5HFORCE,10X,6HSTRESS,6X,
     1        12HTOTAL STRAIN,3X,11HTEMPERATURE,4X,
     2        26HACCUM. EFF. PLASTIC STRAIN,2X,
     3        22HNUMBER OF SUBDIVISIONS,/,18X,4(E14.6,1X),9X,E14.6,
     4        14X,I5)
 2400 FORMAT (/,20X,14HPLASTIC STRAIN,2X,12HCREEP STRAIN,2X,
     1        14HTHERMAL STRAIN,4X,9HEFFECTIVE,4X,12HYIELD STRESS,
     2        6X,32HYIELD STRESS (BASED ON TEMP. AND,/,69X,6HSTRESS,25X,
     3        27HACCUM. EFF. PLASTIC STRAIN),/,18X,5(E14.6,1X),13X,
     4        E14.6)
 3001 FORMAT(//,70H    ERROR   STRESS LOOP NO. 1 FAILED TO CONVERGE   (S
     1UBROUTINE MTBEPC))
 3002 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       13HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       40HAPPROXIMATE REQUIRED SUBDIVISION SIZE = ,E14.6)
 3003 FORMAT(//,70H    ERROR   STRESS LOOP NO. 2 FAILED TO CONVERGE   (S
     1UBROUTINE MTBEPC))
 3004 FORMAT(//,117H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBROUTINE MTBEPC))
 3006 FORMAT(//,131H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 1   (SUBRO
     2UTINE MTBEPC))
 3007 FORMAT(//,117H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 1   (SUBROUTINE MTBEPC))
 3008 FORMAT(//,117H    ERROR   SUBDIVISION SIZE REQUIRED TO ELIMINATE D
     1IVERGENCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBROUTINE MTBEPC))
 3009 FORMAT(//,131H    ERROR   SUBDIVISION SIZE REQUIRED TO SATISFY INE
     1LASTIC STRAIN TOLERANCE IS TOO SMALL IN STRESS LOOP NO. 2   (SUBRO
     1UTINE MTBEPC))
 3010 FORMAT(//,117H    ERROR   MAXIMUM NUMBER OF SUBDIVISIONS WILL NOT
     1REACH END OF TIME STEP IN STRESS LOOP NO. 2   (SUBROUTINE MTBEPC))
 3011 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,/,5X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,2X,
     3       24HLAST SUBDIVISION SIZE = ,E14.6)
 3012 FORMAT(//,72H    ERROR   INCORRECT VALUE CALCULATED FOR *RATIO*
     1(SUBROUTINE MTBEPC))
 3013 FORMAT(//,5X,10HELEMENT = ,I5,1X,20HINTEGRATION POINT = ,I5,1X,
     1       14HSUBDIVISION = ,I5,1X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,1X,
     3        7HIPEL = ,I2,/,5X,
     4        5HRA = ,E14.6,1X,5HRB = ,E14.6,1X,5HRD = ,E14.6,
     5        5HRE = ,E14.6,1X,5HRF = ,E14.6,1X,5HRG = ,E14.6,/,5X,
     6        8HRATIO = ,E14.6,//)
 3014 FORMAT(//,103H    ERROR   DIFFERENCE BETWEEN THE TWO MEASURES OF Y
     1IELD STRESS EXCEEDS TOLERANCE   (SUBROUTINE MTBEPC))
 3015 FORMAT(//,5X,10HELEMENT = ,I5,2X,20HINTEGRATION POINT = ,I5,2X,
     1       14HSUBDIVISION = ,I5,2X,
     2       38HTIME RELATIVE TO START OF TIME STEP = ,E14.6,/,5X,
     3       35HYIELD STRESS (FROM STRESS STATE) = ,E14.6,2X,
     4       54HYIELD STRESS (FROM TEMPERATURE AND ACCUM. EFF. PLASTIC,
     5       11H STRAIN) = ,E14.6,//)
C
      END
C *CDC* *DECK SIGMA1
C *UNI* )FOR,IS  N.SIGMA1, R.SIGMA1
C
      SUBROUTINE SIGMA1(STRSS2,EPS2,EPSP2,EPST2,EPSC1,EPSC2,DPSC,GAMA,
     1                  PTIME,STRNR,F,R,G,EST,DELT,YM2)
C
C
C
C     THIS SUBROUTINE USES A NEWTON-RAPHSON METHOD TO CALCULATE
C     UNIAXIAL STRESS AND CREEP STRAIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
C
C
C
      TSTRSS=STRSS2
C
C        1. FORM FIRST PART OF R.H.S.
C
      RH=YM2*(EPS2 - EPSP2 - EPSC1 - DPSC - EPST2)
C
      IF(XPARM2.GT.0.0.AND.KCRP.GT.0.AND.EST.GT.TOL5) GO TO 35
C
      EPSC2=EPSC1 + DPSC
      STRSS2=RH
C
      RETURN
C
C        2. FORM THE PART OF THE ITERATION FUNCTION USED TO CALCULATE
C           THE R.H.S. AND THE CREEP STRAIN INCREMENT
C
   35 A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 40
C
C     CREEP LAW NO. 1 **
C
      GG=(A1 - A2)*GAMA/A2
      GO TO 50
C
C     CREEP LAW NO. 2 **
C
   40 C2=A4 - 1.0
      C1=1.5*A2*A4*(A3**(-A4))
      C3=1.5*A1
      C4=1.5*A6
C
      D1=DEXP(-R*PTIME)*F
      D2=EST**C2
C
      DTPSP=(D1*(C3 - PTIME*C1*D2) - C3*F - PTIME*C4*G)/STRNR
C
      GG=D1*(C1*D2 - R*(PTIME*C1*D2 + R*DTPSP - C3)) + C4*G - GAMA
C
   50 TTC=XCON1*XPARM2*DELT*(GG + GAMA)
      TC=YM2*TTC
C
C        3. FORM ITERATION FUNCTION AND SECOND PART OF R.H.S.
C
      RH=RH + TC*STRSS2
      TC=TC + 1.0
C
C        4. CALCULATE STRESS AT END OF SUBDIVISION
C
      STRSS2=RH/TC
C
C        5. CALCULATE CREEP STRAIN AT END OF SUBDIVISION
C
      DPSC=DPSC + TTC*(STRSS2 - TSTRSS)
      EPSC2=EPSC1 + DPSC
C
      RETURN
C
      END
C *CDC* *DECK EPMAT1
C *UNI* )FOR,IS  N.EPMAT1, R.EPMAT1
C
      SUBROUTINE EPMAT1(STRSSM,ALFAM,EPSTRM,DEPS,DPSC,DPST,XLAMDA,PROP1,
     1                  PROP2,PROPM,YLDM,KEY,DPSP,INDEX,EETM)
C
C
C     THIS SUBROUTINE CALCULATES THE UNIAXIAL PLASTIC STRAIN
C     INCREMENT
C
C
C
C     KEY = 1  CALCULATE PLASTIC STRAIN INCREMENT  (STRESS CALCULATIONS)
C         = 2  CALCULATE PLASTIC STRAIN INCREMENT  (FORMING
C              STIFFNESS MATRIX)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
      COMMON /TPLAS1/ EETD,YSD
C
      DIMENSION PROP1(1),PROP2(1),PROPM(1)
C
      EQUIVALENCE (NPAR(15),MODEL)
C
C
C
C        1. INITIALIZE VARIABLES
C
      IF(INDEX.GT.1) GO TO 40
C
      YMM=PROPM(1)
      ETM=PROPM(3)
C
      YMD=PROP2(1) - PROP1(1)
      ETD=PROP2(3) - PROP1(3)
      YSD=PROP2(2) - PROP1(2)
C
      EETD=((YMM*YMM*ETD) - (ETM*ETM*YMD))/((YMM - ETM)*(YMM - ETM))
C
C        2. CALCULATE PLASTIC STRAIN INCREMENT
C
   40 DENMP=(YMM + EETM)*YLDM*YLDM
      IF(MODEL.EQ.7) GO TO 50
C
C     ISOTROPIC HARDENING **
C
      WP1=YMM*STRSSM*(DEPS - DPSC - DPST)
      WP2=(YMD/YMM)*YLDM*YLDM - YLDM*(EPSTRM*EETD + YSD)
      STM=STRSSM
      GO TO 70
C
C     KINEMATIC HARDENING **
C
   50 STM=STRSSM - 1.5*ALFAM
      WP1=YMM*STM*(DEPS - DPSC - DPST)
      WP2=(YMD/YMM)*STM*STRSSM - YLDM*YSD
C
   70 WP=WP1 + WP2
      XLAMDA=WP/DENMP
      WPP=XLAMDA
C
C     CHECK FOR UNLOADING OR NEUTRAL LOADING **
C
      IF(XLAMDA.GT.0.0) GO TO 75
      XLAMDA=0.0
      GO TO 80
C
   75 IF(KEY.EQ.2 .AND. IEQREF.NE.1) XLAMDA=XLAMDA - WP1/DENMP
C
   80 DPSP=XLAMDA*STM
      XLAMDA=WPP
C
      RETURN
C
      END
C *CDC* *DECK MTITP1
C *UNI* )FOR,IS  N.MTITP1, R.MTITP1
C
      SUBROUTINE MTITP1(PROP,TMP,PROPI)
C
C
C
C     THIS SUBROUTINE LINEARLY INTERPOLATES THE MATERIAL PROPERTY
C     TABLES AND OBTAINS THE FOLLOWING PROPERTIES AT THE
C     SPECIFIED TEMPERATURE
C
C        YOUNGS MODULUS
C        VIRGIN MATERIAL YIELD STRESS
C        HARDENING MODULUS
C        MEAN COEFFICIENT OF THERMAL EXPANSION
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
C
      DIMENSION PROP(16,1),PROPI(1)
C
C
C
C
C        1. ENTER TEMPERATURE TABLE AND DETERMINE
C           INTERPOLATION FACTOR
C
    5 IF(TMP.GE.RNGL) GO TO 10
      WRITE(6,3001)
      STOP
C
   10 L=0
      DO 20 K=2,NPTS
      L=L + 1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(TMP.GT.DUM) GO TO 20
      GO TO 25
   20 CONTINUE
      WRITE(6,3001)
      STOP
C
   25 XRATIO=(TMP - PROP(L,1))/(PROP(L + 1,1) - PROP(L,1))
C
C     CORRECT XRATIO FOR THE CASE WHEN TMP LIES OUTSIDE TABLE
C     BUT WITHIN THE TOLERANCE RANGE **
C
      IF(XRATIO.GT.1.0) XRATIO=1.0
      IF(XRATIO.LT.0.0) XRATIO=0.0
C
C        2. INTERPOLATE MATERIAL PROPERTIES
C
C     PROPI(J) CONTAINS INTERPOLATED VALUES **
C
C        PROPI(1) = YOUNGS MODULUS
C        PROPI(2) = VIRGIN MATERIAL YIELD STRESS
C        PROPI(3) = HARDENING MODULUS
C        PROPI(4) = MEAN COEFFICIENT OF THERMAL EXPANSION
C
      DO 30 M=2,5
   30 PROPI(M - 1)=PROP(L,M) + XRATIO*(PROP(L + 1,M) - PROP(L,M))
C
      RETURN
C
 3001 FORMAT(//,92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PRO
     1PERTY TEMPERATURES  (SUBROUTINE MTITP1))
C
      END
C *CDC* *DECK CREEP1
C *UNI* )FOR,IS N.CREEP1,R.CREEP1
C
      SUBROUTINE CREEP1(DDT,DEPSC,TEMPD,EPSC,ORIG,NORG,STRESS,GAMA,
     1                  STRNR,PTIME2,EST,F,R,G,INDEX,ECSTR)
C
C
C
C     THIS SUBROUTINE CALCULATES THE CREEP STRAIN RATE USING TOTAL
C     CREEP STRAIN HARDENING AND THE ORNL AUXILIARY HARDENING RULES FOR
C     CYCLIC CREEP
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
C
      DIMENSION ORIG(1)
C
C
C
      IMAX=50
      ETOL1=5.0D-3
      ETOL4=5.0D-6
      ETOL5=1.0D-20
C
C        1. CALCULATE THE CURRENT VALUE OF EFFECTIVE CREEP STRAIN
C
      CALL CYCRP1(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
      IF(EST.LE.TOL5) RETURN
C
      IF(KCRP.EQ.2) GO TO 20
C
C        2. ANALYTICAL SOLUTION FOR CREEP LAW NO. 1
C
      CALL CRPLW1(EST,ECSTR,STRN,STRNR,DDT,TEMPD,F,R,G)
      GO TO 60
C
C        3. NUMERICAL SOLUTION FOR CREEP LAW NO. 2
C
C
C     USE NEWTON ITERATION TO SOLVE FOR CURRENT EFFECTIVE
C     CREEP STRAIN RATE **
C
C
C     MAKE INITIAL GUESS OF PSEUDO-TIME *
C
   20 PTIME1=DBLE(FLOAT(KSTEP))*DTT + TSTART
      PTIME2=PTIME1
C
      KOUNT=1
   25 CALL CRPLW1(EST,ECSTR,STRN,STRNR,PTIME2,TEMPD,F,R,G)
C
      IMOD=0
      FUNCT=STRN-ECSTR
      DELTA=FUNCT/STRNR
      IF(ECSTR.EQ.0.0) DELTA=PTIME2
C
C     MODIFY DELTA, IF NECESSARY, TO OBTAIN A VALUE
C     OF PSEUDO-TIME .GE. 0.0 **
C
      IF((PTIME2 - DELTA).GE.0.0) GO TO 30
      DELTA=0.5*PTIME2
      IMOD=1
C
   30 IF(KOUNT.GT.1) GO TO 40
      PTIME2=PTIME1 - DELTA
      DNORM1=DABS(DELTA)
      KOUNT=KOUNT + 1
      GO TO 25
C
C     APPLY CONVERGENCE CRITERIA FOR KOUNT .GT.1 **
C
   40 DNORM2=DABS(DELTA)
      IF(IMOD.EQ.1) GO TO 50
      IF(DNORM2.LE.DNORM1) GO TO 45
C
C     CHECK IF DNORM1 AND DNORM2 ARE WITHIN THE ROUNDOFF
C     TOLERANCE BAND **
C
      XTOL=ETOL4*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM2.LE.XTOL.AND.DNORM1.LE.XTOL) GO TO 60
      GO TO 50
C
   45 XTOL=ETOL1*PTIME1
      IF(PTIME1.LE.ETOL5) XTOL=ETOL5
      IF(DNORM1.LE.XTOL) GO TO 60
C
C     NO CONVERGENCE *
C
   50 KOUNT=KOUNT + 1
      IF(KOUNT.LE.IMAX) GO TO 55
      WRITE(6,2000)
      STOP
C
   55 PTIME1=PTIME2
      PTIME2=PTIME2 - DELTA
      DNORM1=DNORM2
      GO TO 25
C
C        4. CALCULATE INITIAL ESTIMATE OF INCREMENTAL CREEP STRAINS
C
   60 GAMA=1.5*STRNR/EST
      DEPSC=DDT*STRNR*STRESS/EST
C
      RETURN
C
 2000 FORMAT(//,69H    ERROR   NEWTON ITERATION FAILED TO CONVERGE   (SU
     1BROUTINE CREEP1))
C
      END
C *CDC* *DECK CYCRP1
C *UNI* )FOR,IS N.CYCRP1,R.CYCRP1
C
      SUBROUTINE CYCRP1(ECSTR,EPSC,ORIG,NORG,STRESS,INDEX)
C
C
C
C     THIS SUBROUTINE PERFORMS THE ORNL-TM-3602 AUXILIARY STRAIN
C     HARDENING CALCULATIONS FOR CYCLIC CREEP
C
C     THE FOLLOWING VARIABLES ARE USED
C
C        ORIG(I)     =  ARRAY CONTAINING POSITIVE ORIGIN IN THE FIRST
C                       ROW AND NEGATIVE ORIGIN IN THE SECOND
C        EPSD        =  DISTANCE BETWEEN CURRENT ORIGINS
C        EPSC        =  CURRENT CREEP STRAIN
C        NORG        =  DENOTES CURRENT ORIGIN
C                    =  1 POSITIVE ORIGIN
C                    =  2 NEGATIVE ORIGIN
C        STRESS      =  CURRENT STRESS
C        ECSTR       =  EFFECTIVE STRAIN MEASURE OF THE DISTANCE BETWEEN
C                       THE CURRENT CREEP STRAIN STATE AND ORIGIN
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION ORIG(1)
C
C
C     STRESS REVERSAL CAN OCCUR ONLY AT THE START OF A
C     SUBDIVISION (INDEX = 1)
C
      IF(INDEX.GT.1) GO TO 50
C
C
C        1. CALCULATE CURRENT DISTANCE BETWEEN ORIGINS
C
      EPSD=DABS(ORIG(1) - ORIG(2))
C
C        2. CHECK FOR STRESS REVERSAL
C
      DUM=(EPSC - ORIG(NORG))*STRESS
      IF(DUM.GE.0.0) GO TO 50
C
C     STRESS REVERSAL IS INDICATED **
C
      ECSTR=DABS(EPSC - ORIG(NORG))
C
C     CHECK IF OPPOSITE ORIGIN COORDINATES MUST BE RESET TO
C     NEW VALUES **
C
      IF(ECSTR.GT.EPSD) GO TO 40
C
C     CHECK FOR FALSE STRESS REVERSAL *
C
      IF(NORG.EQ.2) GO TO 18
   17 NN=2
      GO TO 20
   18 NN=1
   20 DUM=(EPSC - ORIG(NN))*STRESS
      IF(DUM.GE.0.0) GO TO 25
C
C     FALSE REVERSAL IS INDICATED
C
      TECSTR=DABS(EPSC - ORIG(NN))
      IF(ECSTR.GE.TECSTR) RETURN
C
C        3. RESET ORIGIN INDICATOR ONLY
C
   25 IF(NORG.EQ.2) GO TO 35
   30 NORG=2
      GO TO 50
   35 NORG=1
      GO TO 50
C
C        4. RESET ORIGIN INDICATOR AND COORDINATES
C
   40 IF(NORG.EQ.2) GO TO 42
   41 NORG=2
      GO TO 45
   42 NORG=1
C
   45 ORIG(NORG)=EPSC
C
C        5. CALCULATE NEW VALUE OF EFFECTIVE CREEP STRAIN
C
   50 ECSTR=DABS(EPSC - ORIG(NORG))
C
      RETURN
C
      END
C *CDC* *DECK CRPLW1
C *UNI* )FOR,IS N.CRPLW1,R.CRPLW1
C
      SUBROUTINE CRPLW1(STRESS,ECSTR,STRAIN,STRNR,TIME,TEMPD,F,R,G)
C
C
C
C     THIS SUBROUTINE CONTAINS THE UNIAXIAL CREEP LAWS FOR MATERIAL
C     MODELS 6 AND 7  (1-D)
C
C
C     THE FOLLOWING VARIABLES ARE USED FOR THE UNIAXIAL LAWS
C
C        STRESS = UNIAXIAL STRESS
C        STRAIN = UNIAXIAL CREEP STRAIN
C        STRNR = UNIAXIAL CREEP STRAIN RATE
C        TIME = TIME
C        TEMPD = TEMPERATURE
C        CRPCON = CONSTANTS FOR UNIAXIAL CREEP LAW
C        ECSTR = MODIFIED EFFECTIVE CREEP STRAIN (O.R.N.L. RULES)
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOLPM1/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
C
C
C
      A0=CRPCON(1)
      A1=CRPCON(2)
      A2=CRPCON(3)
      A3=CRPCON(4)
      A4=CRPCON(5)
      A5=CRPCON(6)
      A6=CRPCON(7)
C
      IF(KCRP.EQ.2) GO TO 50
C
C        1. CREEP LAW NO. 1
C
      IF(A2.GE.1.0) GO TO 20
C
      RTTOL=20.
      EX1=1./(1.-A2)
      EX2=A1*EX1
      EX3=A2*EX1
      EX4=-RTTOL*EX3
C
C     CALCULATE MINIMUM ALLOWABLE EFFECTIVE CREEP STRAIN **
C
      ECMIN=(A0**EX1)*(STRESS**EX2)*(A2**EX3)*(10.0**EX4)
      IF(ECSTR.LE.ECMIN) GO TO 40
C
   20 EX5=1.0/A2
      EX6=A1*EX5
      EX7=(A2-1.)/A2
      IF(A2.EQ.1.0.AND.ECSTR.EQ.0.0) GO TO 25
      EX8=ECSTR**EX7
      GO TO 30
   25 EX8=1.0
C
   30 STRNR=(A0**EX5)*(STRESS**EX6)*A2*EX8
C
      RETURN
C
   40 STRAIN=A0*(STRESS**A1)*(TIME**A2)
      STRNR=STRAIN/TIME
C
      RETURN
C
C        2. CREEP LAW NO. 2
C
   50 F=A0*DEXP(A1*STRESS)
      R=A2*((STRESS/A3)**A4)
      G=A5*DEXP(A6*STRESS)
      STRAIN=F*(1.-DEXP(-R*TIME)) + (G*TIME)
      STRNR=F*R*DEXP(-R*TIME) + G
C
      RETURN
C
      END
C *CDC* *DECK TUSMOD
C *UNI* )FOR,IS N.TUSMOD,R.TUSMOD
      SUBROUTINE TUSMOD
      IMPLICIT REAL*8 (A-H,O-Z)
      RETURN
      END