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

Text File | 1991-01-07 | 213.6 KB | 7,005 lines

C *** OVLMAIN
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMN/ N3A,N4A,N4B,N4C
      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 /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1           N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /SHV1/ N010
      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 /MSUPCF/ B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /DISCON/ NDISCE,NIDM
      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 /ITMTHD/ MAXUP,NUMUPD,NTBFGS,NATKN
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /ENERGY/ PE,PEOLD,PEINIT
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PRCONS/ IPRICS
      COMMON /TICON/ IPRIT
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /DPR/ ITWO
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /SRANDI/ N09A,N09B
      COMMON /STORES/ MXTMPS,MDVAS,MXSTHS,MXNEQS,MXBLCS,MXNN1
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MDFRDM/ IDOF(6)
      COMMON /BLOCKS/ NSREFB,NEQITB,NPRIB,NODSVB,LEMSVB,ISREFB(3,10),
     1                IEQITB(3,10),IPRIB(3,10),INODB(3,10),IELMB(3,10)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /PORTT/ JTC
      COMMON /MINDEX/ MITWO(2),MITEN(2)
      COMMON /RANDAC/ NR(5),LR(5)
      COMMON /SKEW/ NSKEWS
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /PRGCON/ ICPRI,NTU
      COMMON /PRSHAP/ KSHAPE
      COMMON /NMDATA/ KSET
      COMMON /FACDBL/ JFAC
C
      COMMON A(65015)
      INTEGER IA(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
C     RANDOM ACCESS I/O IS USED IN THE FOLLOWING SUBROUTINES ALSO -
C     *  SUBSTR, ELCAL, ASSEM, LOADEF, COLSOL, UNBLD, STRESS,
C        SUBSKR, RSTART, BANDET, MSUBSP *
C
C     C D C  RANDOM ACCESS EXTERNAL SUBROUTINES -
C     OPENMS, STINDX, READMS, WRITMS, CLOSMS
C
C     I B M RANDOM ACCESS EXTERNAL SUBROUTINE - DEFINE FILE
C     SPECIAL ADINA SUBROUTINES FOR IBM ONLY - READMS, WRITMS
C
C         PRIOR AND AFTER A RANDOM ACCESS READ/WRITE THE FOLLOWING CARDS
C     HAVE BEEN INCLUDED
C
C        * * * * *        R A N D O M  A C C E S S        * * * *
C
C
C     CREATE RANDOM FILES 2,10 WITH NUMBER INDEX
C
C        * * * * * *          R A N D O M  A C C E S S        * * * *
C
C   NOTE/ THIS IBM VERSION OF ADINA CAN BE USED TO STORE ONLY 190*3000
C     SINGLE PRECISION WORDS ON EACH OF THE UNITS 2 AND 10. RESET NR, LR
C     IN THE FOLLOWING CARDS TO OBTAIN MORE SPACE AND ALSO MODIFY
C     DEFINE FILE STATEMENTS ACCORDINGLY -
C     NR(I) = MAX. NUMBER OF LOGICAL RECORDS ON UNIT I
C     LR(I) = LENGTH OF EACH LOGICAL RECORD ON UNIT I
C
      NR(1)=190
      NR(2)=190
      LR(1)=3000
      LR(2)=3000
      DEFINE FILE 10 (190,3000,U,NREC10)
      DEFINE FILE 2 (190,3000,U,NREC2)
C
C        * * * * * *          R A N D O M  A C C E S S        * * * *
C
C   NOTE/ THIS VERSION OF ADINA USES ONLY A LIMITED BLANK COMMON OF
C     SIZE=25000, DEFINED BY THE VARIABLE MTOT. RESET MTOT AND
C     REDIMENSION COMMON A TO OBTAIN LARGER/SMALLER BLANK COMMON STORAGE
C
      CALL ERRSET (187,256,-1,1)
      CALL ERRSET (208,256,-1,1)
C     CALL CPUINT
      MTOT=65000
C
C     ITWO IS THE VARIABLE THAT GOVERNS STORAGE ALLOCATION FOR REAL
C     VARIABLES STORED IN BLANK COMMON.
C     ITWO = 1, SINGLE PRECISION
C     ITWO = 2, DOUBLE PRECISION
C
C *CDC*      ITWO=1
      ITWO=2
      NBCST=MTOT
      NBCST=0
      KSET=0
      JFAC=0
      WRITE (6,2000)
      WRITE (6,2005)
C     WRITE (6,2006)
C     WRITE (6,2007)
  200 NUMEST=0
      MAXEST=0
      NBCEL=0
      NUMREF=0
      ITE=0
      KPRI=1
      KSTEP=0
      IND=0
      ISUB=0
      NSTAPE=14
      ICOUNT=2
      MIDIND=0
      MXTMPS=0
      MDVAS=0
      MXSTHS=0
      MXNEQS=0
      MXBLCS=0
      KPLOTN = 0
      NSUB = 0
      MXNN1=0
      KSHAPE=0
C
C
C     I N P U T   P H A S E
C
C
      CALL SECOND (TIM1)
C
      N0=1 + NBCST
C
C     R E A D   F I N I T E   E L E M E N T   M E S H   D A T A
C
C
C *CDC*      CALL OVERLAY (5HADINA,1,0,6HRECALL)
      CALL ADINI
C
C     CLEAR ARRAY FOR CALCULATION OF COLUMN HEIGHTS
C
      NN=N5 + NEQ - 1
      DO 2 I=N5,NN
    2 IA(I)=0
      N6=N5 + NEQ
C
C     INITIALIZE TEMPERATURE ARRAY
C
      IF (ITP96.EQ.0) GO TO 14
      N6A=N5 + NEQ
      N6B=N6A
      N6=N6A + (NUMNP+1)*ITWO
      NN=N6 - 1
      READ (56) (A(I),I=N6A,NN)
      CALL TCHECK (A(N6A),TSTART)
      BACKSPACE 56
C
C     O B T A I N   E L E M E N T   I N F O R M A T I O N S
C
   14 CALL ELCAL (NEGL,NEGNL,MAXEST,ISUB)
C
      CALL SECOND (TIM2)
C
C     COMPACT THE MID-SURFACE NORMAL SYSTEM
C
      N1=N08
      IF (NMIDSS .EQ. 0 .OR. MIDIND .EQ. 0) GO TO 12
      N09A=N09 + 3*MAXMSS*ITWO
      N09B=N09A + MIDIND
      CALL COMPCT (IA(N08),A(N09),IA(N09A),A(N09B))
      N09=N08 + MIDIND
      MAXST=3*MIDIND*ITWO
      DO 11 I=1,MAXST
   11 A(N09+I-1)=A(N09B+I-1)
      N010=N09 + MAXST
      N1=N010 + MAXST
   12 MAXMSS=MIDIND
C
C
C     S U B S T R U C T U R E   D A T A   I N P U T
C
C
      IF (NSUBST.EQ.0) GO TO 20
C
      IF (NMIDSS.EQ.0) GO TO 15
      NN=N1 + NDOF*NUMNP - 1
      REWIND 8
      READ (8) (IA(I),I=N1,NN)
C
   15 ISUB=1
      CALL SUBSTR
      ISUB=0
   20 CALL SECOND (TIM3)
C
C     COMPUTE MAXA ARRAY
C
      IF (IOPE.NE.3) CALL ADDRES (A(N1),A(N5),NEQ,NWK,MA)
C
C
C     S T O R A G E   C A L C U L A T I O N S
C
C
C     TEST FOR AVAILABILITY OF HIGH SPEED STORAGE AND CALCULATE
C     MAXIMUM BLOCKSIZE, NUMBER OF BLOCKS, AND BLOCK COUPLING
C
      CALL STORE (NUMNP,NDOF,NEQ,NWK,MA,NEGNL,MAXEST,NBLOCK,ISTOH,1)
C
      IF (MODEX.GT.0) GO TO 50
      IND=2
      GO TO 51
C
C
C     S U B S T R U C T U R E   S T I F F N E S S   M A T R I C E S
C
C
   50 IND=1
      IREF=0
      IF (NSUBST.EQ.0) GO TO 51
      ISUB=1
      CALL SUBSTR
      ISUB=0
C
C     CREATE RANDOM ACCESS FILE 10 WITH ASSOCIATED RECORD NUMBER INDEX
C
C       * * * * *        R A N D O M  A C C E S S        * * * *
C
   51 NBLOC1=(IEIG + 1)*NBLOCK + 1
      IF (IOPE.EQ.3) GO TO 55
C *CDC*      CALL OPENMS (10,MITEN,2,0)
C *IBM DEACTIVATE ABOVE 1 CARD FOR  IBM
      DO 52 I=1,NBLOC1
      J=N1D + (I-1)
   52 IA(J)=0
C *CDC*      CALL STINDX (10,IA(N1D),NBLOC1,0)
C *IBM* DEACTIVATE ABOVE CARD FOR IBM
C
C       * * * * *        R A N D O M  A C C E S S        * * * *
C
C     A S S E M B L A G E   O F   L I N E A R   M A T R I C E S
C
C
   55 IF (MODEX.EQ.0) GO TO 60
      CALL ASSEM (A(N1),A(N2),A(N3),A(N4),A(N5),A(N5),A(N6),A(N1A),
     1            A(N4),A(N1C),A(N6),A(N04),A(N05),ISTOH,NBLOCK)
C
C
C     C A L C U L A T E   A N D   S T O R E   L O A D   V E C T O R S
C
C
C *CDC*   60 CALL OVERLAY (5HADINA,17B,0B,6HRECALL)
   60 CALL LOAD
C
C
C     S U B S T R U C T U R E   L O A D   V E C T O R S
C
C
      IF (NSUBST.EQ.0) GO TO 61
      ISUB=1
      CALL SUBSTR
      ISUB=0
C
   61 CALL SECOND (TIM4)
C
      IF (IDATWR.LE.1) WRITE (6,2010)
C
C
C     S T O R A G E   F O R   T I M E   I N T E G R A T I O N
C
C
      CALL STORE (NUMNP,NDOF,NEQ,NWK,MA,NEGNL,MAXEST,NBLOCK,ISTOH,2)
C
C
C     I N I T I A L    C O N D I T I O N S
C
C
C        1. MASTER STRUCTURE
C
      NEQT=NEQ + NDISCE
C
C     TAKE INITIAL CONDITIONS INTO CORE FORM TAPE8. GENERATE FOR
C     CONSTRAINED DEGREES OF FREEDOM
C
      CALL WRITE (A(N1),A(N2),A(N7),A(N8),A(N5),IDOF,ISUB,NEQ,NDOF,0)
C
C     IF THIS IS A RESTART JOB, TRANSFER NONLINEAR ELEMENT GROUP
C     DATA TO TAPE 2
C
      IF (MODEX.NE.2) GO TO 64
      CALL RSTART (A(N1),A(N2),A(N7),A(N8),A(N10),A(N1C),NEQ,NBLOCK,2)
C
   64 IF (IOPE.EQ.3 .AND. NDISCE.GT.0)
     1 CALL CONDIS (A(N01),A(N02),A(N03),A(N1),A(N7),A(N8),NIDM,0)
C
      IF (NDISCE.GT.0)
     1 CALL CONDIS (A(N01),A(N02),A(N03),A(N2),A(N7),A(N8),NIDM,ISTAT)
C
C     WRITE INITIALIZED DISPLACEMENTS, VELOCITIES, AND ACCELERATIONS
C        ( OR STARTING DISPL/VEL/ACC IF THIS IS A RESTART JOB )
C
      MM=N2
      IF (IOPE.EQ.3) MM=N1
      ICPRI=1
      TIME = TSTART
      NSUB = 0
      CALL WRITE (A(N1),A(MM),A(N7),A(N8),A(N5),IDOF,ISUB,NEQT,NDOF,1)
C
C        2. SUBSTRUCTURES
C
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 82
      ISUB=1
      REWIND NSTAPE
      NEQT=NEQ + NDISCE
      M2=N2 + NEQT*ITWO
      M7=N7 + NEQT*ITWO
      M8=N8 + NEQT*ITWO
      IF (IPRIC.EQ.0) GO TO 74
      REWIND 15
      DO 72 I=1,NTFN
   72 READ (15)
   74 DO 76 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1              NDOFS
      IF (IPRIC.EQ.0) GO TO 75
      NN=N5 + NDOFS*NUMNPS - 1
      READ (15) (IA(I),I=N5,NN)
      READ (15)
      READ (15)
      READ (15)
   75 DO 76 NTU =1,NTUSE
      READ (NSTAPE)
      CALL WRITE (A(N1),A(M2),A(M7),A(M8),A(N5),IDOFS,
     1            ISUB,NEQS,NDOFS,0)
      ICPRI=1
      CALL WRITE (A(N1),A(M2),A(M7),A(M8),A(N5),IDOFS,
     1            ISUB,NEQS,NDOFS,1)
      M2=M2 + NEQS*ITWO
      M7=M7 + NEQS*ITWO
      M8=M8 + NEQS*ITWO
   76 CONTINUE
      ISUB=0
C     INITIALIZE TEMPERATURE ARRAY AND PRINT THEM, IF REQUESTED
C
   82 IF (ITEMPR.EQ.0) GO TO 65
      NN=N6A + (NUMNP + 1)*ITWO - 1
      READ (56) (A(I),I=N6A,NN)
      NN=N6A + ITWO
      CALL WRITEM (A(N6A),A(NN),NUMNP,1)
C
C
C     F R E Q U E N C Y   S O L U T I O N
C
C
   65 CALL SECOND (TIM5)
      IF (IEIG.EQ.0) GO TO 69
      IND=3
      TIME=TSTART + DT
      CALL ASSEM (A(N1),A(N4),A(N4A),A(N2),A(N3),A(N5),A(N10),A(N1A),
     1            A(N6B),A(N1C),A(N6),A(N04),A(N05),ISTOH,NBLOCK)
   69 CALL SECOND (TIM6)
C
C     INITIALISE VARIABLES FOR MODE SUPERPOSITION ANALYSIS
C
      IF (IMODES.EQ.0) GO TO 70
      IF (MODEX.EQ.0) GO TO 70
      IND=3
C
C *CDC*      CALL OVERLAY (5HADINA,21B,0B,6HRECALL)
      CALL MODSUP
   70 CALL SECOND (TIM7)
C
C
C     T I M E   I N T E G R A T I O N
C
C
      TSUM1=0.
      TSUM2=0.
      TSUM3=0.
      TSUM4=0.
      TSUM4A=0.
      TSUM5=0.
      TSUM6=0.
      TIM8=TIM7
      IF (MODEX.GT.0) GO TO 88
      WRITE(6,2030)
      GO TO 190
   88 IF (NSTE.EQ.0) GO TO 190
C
C
C     FOR MID-SURFACE SYSTEMS STORE INITIAL NORMALS ON TAPE9
C
      IF (MAXMSS.EQ.0) GO TO 90
      REWIND 9
      NN=N010-1
      WRITE (9) (A(I),I=N09,NN)
C
C     INITIAL VECTORS V1 ARE TO BE CALCULATED
C     AND STORED ON TAPE 9
C
      KNOR=1
      CALL NORMAL (A(N08),A(N09),A(N010),A(N3),A(N5),NDOF,KNOR)
      KNOR=2
C
   90 TIME=TSTART
      TIMEP=TSTART
      REWIND 3
      REWIND 13
      IND=4
      KRINT=0
      NUMP1=(NUMNP+1)*ITWO
C
C     IN CASE OF LINEAR ANALYSIS TRIANGULARIZE EFFECTIVE LINEAR
C     STIFFNESS MATRIX (THE TRIANGULAR FACTORS REMAIN IN CORE
C     PROVIDED THAT
C              1.   LINEAR ANALYSIS
C              2.   ONE BLOCK CASE
C              3.   IMPLICIT TIME INTEGRATION SCHEME IS USED)
C
      CALL SECOND (TIM7)
      IF (KLIN.GT.0 .OR. IOPE.EQ.3) GO TO 94
      IF (IMODES.GT.0) GO TO 94
      NTAPE=4
      IF (ISTAT.EQ.1) NTAPE=7
      CALL COLSOL (A(N1),A(N1A),A(N1B),A(N4),A(N4A),A(N4B),A(N3),A(N04),
     1            NEQ,NBLOCK,ISTOH,NTAPE,10,1)
      WRITE (6,2320) SMAX,SMIN,DMAX,DMIN
      RATIO=DMAX/DMIN
      IF (RATIO.LT.1.D+11) GO TO 94
      WRITE (6,2330)
   94 CALL SECOND (TIM8)
      IF (IMODES.GT.0) GO TO 100
      IF (IOPE.NE.3) GO TO 95
C
C     FOR CENTRAL DIFFERENCE METHOD TAKE EFFECTIVE MASS INTO CORE.
C     HOWEVER IF DAMPING TERMS ARE PRESENT,  THEN AT EACH TIME STEP BOTH
C     LUMPED AND EFFECTIVE MASS MATRICES ARE READ INTO CORE FROM TAPE
C
      REWIND 7
      NN=N5 - 1
      READ (7) (A(I),I=N4,NN)
      GO TO 100
C
C     LUMPED MASS MATRIX IS TAKEN INTO CORE AND NODAL DAMPING VECTOR
C     IS STORED AS FIRST RECORD (IMPLICIT TIME INTEGRATION)
C
   95 IF (IMASS.NE.1) GO TO 100
      REWIND 11
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 97
      II=NSUBST*2
      DO 96 I=1,II
   96 READ (11)
   97 NN=N9 + NEQ*ITWO - 1
      READ (11) (A(I),I=N9,NN)
      NN=N6 + NEQ*ITWO - 1
      READ (11) (A(I),I=N6,NN)
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 98
      BACKSPACE 11
      BACKSPACE 11
      WRITE (11) (A(I),I=N6,NN)
      BACKSPACE 11
      GO TO 100
   98 REWIND 11
      WRITE (11) (A(I),I=N6,NN)
      REWIND 11
C
C
C     T I M E   S T E P   I N C R E M E N T A T I O N
C
C        KSTEP .EQ. STEP COUNTER
C        TIME .EQ. TIME AT WHICH SOLUTION IS REQUIRED
C
C
  100 KSTEP=KSTEP + 1
      TIMEP=TIME + DTA
      TIME=TIME + DT
C
C     STIFFNESS REFORMATION FLAG
C        IREF.EQ.0 IF STIFFNESS IS TO BE REFORMED
C
      CALL BLKCNT(KSTEP,NSREFB,IREF,ISREFB,NSTE,1)
      IF (KSTEP.EQ.1) IREF=0
      IF (IOPE.EQ.3 .OR. IMODES.GT.0) IREF=1
C
C     FLAG FOR EQUILIBRIUM ITERATION
C        IEQUIT.EQ.0 IF ITERATION IS TO BE PERFORMED
C        IEQUIT.GT.0 IF NO ITERATION IS TO BE PERFORMED
C
      CALL BLKCNT(KSTEP,NEQITB,IEQUIT,IEQITB,NSTE,2)
C
C     FLAG FOR TRIANGULARIZATION AND/OR SIMPLE REDUCTION AND
C     BACKSUBSTITUTION IN COLSOL
C        KTR.EQ.1   FOR TRIANGULARIZATION PLUS SOLUTION
C        KTR.EQ.2   FOR VECTOR SOLUTION ONLY
C
      KTR=1
      IF (IREF.NE.0) KTR=2
      IF (KLIN.EQ.0) KTR=2
C
C     NEQREF IS THE NUMBER OF TIMES THE NONLINEAR STIFFNESS MATRIX
C     WAS REFORMED
C
      NEQREF=0
  140 REWIND 4
      REWIND 7
C
C     FLAG TO INDICATE CONVERGENCE IN EQUILIBRIUM ITERATION
C        IEQREF.EQ.0   CONVERGENCE
C        IEQREF.EQ.1   NORM OF OUT-OF-BALANCE LOADS IS LARGER THAN NORM
C                      OF INCREMENTAL LOADS (SEE EQUIT)
C
      ISDVG=0
      IEQREF=0
C
C
C     S O L U T I O N   O F   I N C R E M E N T A L   E Q U A T I O N S
C
C
C     UPDATE NORMAL VECTORS IF MID-SURFACE SYSTEMS ARE USED AND
C     MAXMSS IS GREATER THAN 0 ( FOR CENTRAL DIFFERENCE METHOD ONLY)
C
      IF (IOPE.NE.3 .OR. MAXMSS.EQ.0) GO TO 148
      NN=NEQ + NDISCE
      FACTOR=0.
      CALL SHTADV (A(N3),A(N2),A(N1),FACTOR,NN,1)
      CALL NORMAL (A(N08),A(N09),A(N010),A(N3),A(N5),NDOF,KNOR)
C
C     CALCULATE LINEAR EFFECTIVE LOADS BALANCED IN CURRENT CONFIGURATION
C
  148 CALL SECOND (TIM9)
C
      CALL LOADMS
C
      CALL SECOND (TIM10)
C
C     CALCULATE EFFECTIVE NONLINEAR MATRIX AND FINAL EFFECTIVE LOADS
C
      CALL ASSEM (A(N1),A(N4),A(N4A),A(N2),A(N3),A(N5),A(N10),A(N1A),
     1            A(N6B),A(N1C),A(N10),A(N04),A(N05),ISTOH,NBLOCK)
C
      CALL SECOND (TIM11)
      IF (KSTEP.EQ.1 .AND. IREF.EQ.0) WRITE (6,2300) TIM11
C
C     IF ITERATION IS TO BE PERFORMED, SAVE LOAD INCREMENT IN A(N5)
C
      IF (IEQUIT.NE.0 .OR. IMODES.GT.0) GO TO 155
      NN=NEQ*ITWO
      DO 150 I=1,NN
  150 A(N5 + I - 1)=A(N3 + I - 1)
  155 CONTINUE
C
C     SOLVE FOR INCREMENT IN DISPLACEMENT VECTOR
C      CENTRAL DIFF METHOD - IN NEWDAV
C      STATICS OR DIRECT INTEGRATION - IN COLSOL
C      MODE SUPERPOSITION ANALYSIS - IN MODSUP (OVERLAY 21)
C
      IF (IOPE.EQ.3) GO TO 158
      IF (IMODES.GT.0) GO TO 157
      CALL COLSOL (A(N1),A(N1A),A(N1B),A(N4),A(N4A),A(N4B),A(N3),
     1             A(N04),NEQ,NBLOCK,ISTOH,12,10,KTR)
      GO TO 158
C
C *CDC*   157 CALL OVERLAY (5HADINA,21B,0B,6HRECALL)
  157 CALL MODSUP
C
  158 CALL SECOND (TIM12)
      IF (KSTEP.EQ.1 .AND. IREF.EQ.0) WRITE (6,2310) TIM12
C
C     FLAG FOR PRINTING NODAL AND ELEMENT RESPONSES
C        IPRI .EQ. 0 FOR PRINTOUT OF DISP,VEL,ACC AND STRESSES
C
      CALL BLKCNT (KSTEP,NPRIB,IPRI,IPRIB,NSTE,3)
      IF (IPRI.NE.0) GO TO 151
      ICPRI=1
      WRITE (6,2020) KSTEP,TIME
      IF (NSKEWS.LE.0) GO TO 152
      ICPRI=ICPRI+2
      WRITE (6,2025)
      GO TO 152
  151 WRITE (6,2290) KSTEP,TIME
  152 IF (IOPE.EQ.3 .OR. KTR.NE.1) GO TO 153
      IF (IPRI.EQ.0) ICPRI=ICPRI+10
      WRITE (6,2320) SMAX,SMIN,DMAX,DMIN
      RATIO=DMAX/DMIN
      IF (RATIO.LT.1.E+11) GO TO 153
      WRITE (6,2330)
  153 CONTINUE
      TSUM1=TSUM1 + (TIM10 - TIM9)
      TSUM2=TSUM2 + (TIM11 - TIM10)
      TSUM3=TSUM3 + (TIM12 - TIM11)
C
C
C     I T E R A T I O N   F O R   D Y N A M I C   E Q U I L I B R I U M
C
C
C     NO ITERATION IN LINEAR ANALYSIS
C
      IF (KLIN.EQ.0) GO TO 110
C
      IF (IEQUIT.NE.0) GO TO 110
C
      CALL SECOND (TIM13)
C
      IF (NDISCE.GT.0)
     1  CALL CONDIS (A(N01),A(N02),A(N03),A(N3),A(N7),A(N8),NIDM,0)
C
      CALL EQUIT (A(N4),A(N3),A(N3A),A(N5),A(N2),A(N7),A(N8),A(N1),
     1            A(N6),A(N9),A(N10),A(N4A),A(N4B),A(N1A),A(N1B),ISTOH)
C
C     IF NO CONVERGENCE IN ITERATION PROCEED TO NEXT DATA CASE
C
      CALL SECOND (TIM14)
      TSUM4=TSUM4 + (TIM14 - TIM13)
C
      IF(ITE.GT.ITEMAX) GO TO 190
C
C     CHECK FOR NO CONVERGENCE IN EQUILIBRIUM ITERATION AND
C     POSSIBLE REFORMATION OF STIFFNESS
C
      IDVRG=0
      IF (IEQREF.EQ.0) GO TO 110
      IDVRG=1
C
      CALL SECOND (TIM13A)
C
      CALL DIVERG (A(N2),A(N3),A(N3A),A(N4),A(N5),A(N6),A(N7),A(N8),
     1             A(N9),A(N10),A(N4A),A(N4B),A(N1A),A(N1B),A(N1),
     2             A(N1C),A(N6B))
C
      CALL SECOND (TIM14A)
      TSUM4A=TSUM4A + (TIM14A - TIM13A)
C
      IF (ITE.GT.ITEMAX) GO TO 190
      IF (ISDVG.EQ.0) GO TO 110
      WRITE (6,2040)
      KSTEP=KSTEP - 1
      GO TO 190
C
  110 CALL SECOND (TIM15)
C
C
C     FLAGS FOR PRINTING, SAVING NODAL AND ELEMENT RESPONSES
C        KPRI MASTER CONTROL- .EQ.0  STRESS CALCULATIONS
C                             FOR PRINTING OR SAVING PURPOSES ONLY
C        KPLOTN.EQ.0 FOR SAVING NODAL DISP, VEL, ACC VECTORS
C        KPLOTE.EQ.0 FOR SAVING ELEMENT STRESSES
C
      CALL BLKCNT(KSTEP,NODSVB,KPLOTN,INODB,NSTE,4)
      CALL BLKCNT(KSTEP,LEMSVB,KPLOTE,IELMB,NSTE,5)
      KPRI=IPRI
      IF (KPRI.NE.0) KPRI=KPLOTE
C
C     CALCULATE NEW DISP, VEL, ACC VECTORS AT TIME=TSTART + KSTEP*DT
C     FOR STATIC ANALYSIS AND IMPLICIT TIME INTEGRATION AND ALSO DISP
C     VECTOR AT TIME=TSTART + (KSTEP + 1)*DT FOR CENTRAL DIFFERENCE
C     METHOD
C
      CALL NDAVMS
C
      MM=N2
      IF (IOPE.EQ.3) MM=N3
      IF (NDISCE.GT.0)
     1 CALL CONDIS (A(N01),A(N02),A(N03),A(MM),A(N7),A(N8),NIDM,ISTAT)
C
C     UPDATE NORMAL VECTORS IF MID-SURFACE SYSTEMS ARE USED AND
C     MAXMSS IS GREATER THAN 0
C
      IF (IOPE.EQ.3 .OR. MAXMSS.EQ.0) GO TO 159
      IF (NDISCE.GT.0)
     1  CALL CONDIS (A(N01),A(N02),A(N03),A(N3),A(N7),A(N8),NIDM,0)
C
      CALL NORMAL (A(N08),A(N09),A(N010),A(N3),A(N5),NDOF,KNOR)
C
  159 CALL SECOND (TIM16)
      TSUM5=TSUM5 + (TIM16 - TIM15)
      IF (IDVRG.EQ.1) GO TO 160
      IF (IEQUIT.EQ.0) WRITE (6,2060) ITE
      IF (IEQUIT.GT.0) WRITE (6,2050)
      IF (IREF.EQ.0) WRITE(6,2070)
      IF (IREF.NE.0) WRITE(6,2080)
      IF (IPRI.EQ.0) ICPRI=ICPRI+3
  160 CONTINUE
C
C     PRINT DISPLACEMENTS,VELOCITIES AND ACCELERATIONS
C
      NSUB = 0
      CALL WRITE (A(N1),A(N2),A(N7),A(N8),A(N5),IDOF,ISUB,NEQT,NDOF,2)
C
      IF (KPRI.NE.0) GO TO 170
      CALL SECOND (TIM17)
      TSUM5=TSUM5 + (TIM17 - TIM16)
C
C
C     C A L C U L A T I O N   O F   S T R E S S E S
C
C
      CALL STRESS (A(N10),ISUB,NEGL,NEGNL)
C
      CALL SECOND (TIM18)
      TSUM6=TSUM6 + (TIM18 - TIM17)
      KPRI=1
C
C     UPDATE DISPLACEMENT VECTORS, IF CENTRAL DIFFERENCE METHOD IS USED
C
  170 IF (IOPE.EQ.3)
     1   CALL NEWDAV (A(N4),A(N3),A(N5),A(N1),A(N2),A(N3),A(N7),A(N8),
     2               A(N04),A(N05),NEQT,2)
C
C     SHIFT TEMPERATURE ARRAY (IF APPLICABLE)
C
      IF (ITEMPR.LT.2) GO TO 175
      DO 174 I=1,NUMP1
  174 A(N6A+I-1)=A(N6B+I-1)
  175 N6ANN = N6A + ITWO
      IF (ITEMPR.GT.0) CALL WRITEM (A(N6A),A(N6ANN),NUMNP,1)
C
C
C     P R E P A R E   T A P E S   F O R    P O S S I B L E
C                      F U T U R E   R E S T A R T   J O B
C
C
C     FLAG FOR SAVING RESTART INFORMATION
C        IRR.EQ.0 SAVE INFORMATION
C        IRR.GT.0 NO SAVE
C
  180 KRINT=KRINT + 1
      IRR=IRINT - KRINT
      IF (KSTEP.EQ.NSTE) IRR=0
      IF (IRR.GT.0) GO TO 120
      KRINT=0
C
      CALL RSTART (A(N1),A(N2),A(N7),A(N8),A(N10),A(N1C),NEQ,NBLOCK,1)
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 120
      ISUB=1
      REWIND NSTAPE
      NEQT=NEQ + NDISCE
      M2=N2 + NEQT*ITWO
      M7=N7 + NEQT*ITWO
      M8=N8 + NEQT*ITWO
      DO 125 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      READ (NSTAPE) NTUSE
      DO 125 NTU=1,NTUSE
      READ (NSTAPE)
      CALL RSTART (A(N1),A(M2),A(M7),A(M8),A(N10),A(N1C),NEQS,NBLOCK,1)
      M2=M2 + NEQS*ITWO
      M7=M7 + NEQS*ITWO
      M8=M8 + NEQS*ITWO
  125 CONTINUE
      ISUB=0
C
C     SAVE MASTER DISPLACEMENTS ON TAPE15, IF SUBSTRUCTURES ARE USED
C
  120 IF (NSUBST.EQ.0) GO TO 130
      NN=N3 - 1
      WRITE (15) (A(I),I=N2,NN)
C
C
  130 IF (KSTEP.LT.NSTE) GO TO 100
C
C
C     S U B S T R U C T U R E S   R E S P O N S E S
C
C
  190 CALL SECOND (TIM19)
      IF (MODEX.EQ.0) GO TO 191
      IF (NSUBST.EQ.0) GO TO 191
      IND=4
      ISUB=1
      CALL SUBSTR
C
C
C     P R I N T   T I M E   L O G
C
  191 CALL SECOND (TIM20)
      WRITE (6,2090) IHED
      TIM10=TIM2 - TIM1
      TIM10A=TIM3 - TIM2
      TIM11=TIM4 - TIM3
      TIM12=TIM6 - TIM5
      TIM12A=TIM7 - TIM6
      TIM13=TIM8 - TIM7
      TIM14=TIM19 - TIM8
      TIM14A=TIM20 - TIM19
      TIM15=TIM20 - TIM1
      WRITE (6,2100) TIM10,TIM10A,TIM11,TIM12,TIM12A,TIM13
      WRITE (6,2110) KSTEP,TSUM1,TSUM2,TSUM3,TSUM4,TSUM4A,TSUM5,TSUM6,
     1               TIM14,TIM14A,TIM15
C
C        * * * * * *          R A N D O M  A C C E S S        * * * *
C
      IF (KLIN.EQ.0) GO TO 192
C *CDC*      CALL STINDX (2,MITWO,2,0)
C *CDC*      CALL CLOSMS (2)
  192 IF (IOPE.EQ.3) GO TO 195
C *CDC*      CALL STINDX (10,MITEN,2,0)
C *CDC*      CALL CLOSMS (10)
C
C *IBM*   DEACTIVATE ABOVE TWO CARDS FOR IBM MACHINE
C
C        * * * * * *          R A N D O M  A C C E S S        * * * *
C
  195 KSET=KSET+1
      GO TO 200
C
C
 2000 FORMAT (1H1,//////////,21X,92(1H*),/,21X,92(1H*),/,2(21X,2H**,
     1 88X,2H**,/),
     2 21X,2H**,30X,28HA FINITE ELEMENT PROGRAM FOR ,30X,2H**,/,
     1 21X,2H**,20X,48HAUTOMATIC DYNAMIC INCREMENTAL NONLINEAR ANALYSIS,
     2               20X,2H**,/,2(21X,2H**,88X,2H**,/),21X,2H**,9X,
     310(1HA),4X,9(1HD),6X,12(1HI),3X,2HNN,8X,2HNN,4X,10(1HA),9X,2H**,/,
     4 21X,2H**,8X,12(1HA),3X,10(1HD),5X,12(1HI),3X,3HNNN,7X,2HNN,3X,
     5 12(1HA),8X,2H**,/,21X,2H**,8X,2HAA,8X,2HAA,3X,2HDD,7X,2HDD,9X,
     6 2HII,8X,4(1HN),6X,2HNN,3X,2HAA,8X,2HAA,8X,2H**,/,21X,2H**,8X,
     7 2HAA,8X,2HAA,3X,2HDD,8X,2HDD,8X,2HII,8X,2HNN,1X,2HNN,5X,2HNN,3X,
     82HAA,8X,2HAA,8X,2H**,/,21X,2H**,8X,2HAA,8X,2HAA,3X,2HDD,8X,2HDD,
     9 8X,2HII,8X,2HNN,2X,2HNN,4X,2HNN,3X,2HAA,8X,2HAA,8X,2H**,/,21X,2H*
     1*,8X,12(1HA),3X,2HDD,8X,2HDD,8X,2HII,8X,2HNN,3X,2HNN,3X,2HNN,3X,
     2 12(1HA),8X,2H**)
 2005 FORMAT (21X,2H**,8X,12(1HA),3X,2HDD,8X,2HDD,8X,2HII,8X,2HNN,4X,
     12HNN,2X,2HNN,3X,12(1HA),8X,2H**,/,21X,2H**,8X,2HAA,8X,2HAA,3X,2HDD
     2,8X,2HDD,8X,2HII,8X,2HNN,5X,2HNN,1X,2HNN,3X,2HAA,8X,2HAA,8X,2H**,/
     3 ,21X,2H**,8X,2HAA,
     4 8X,2HAA,3X,2HDD,8X,2HDD,8X,2HII,8X,2HNN,6X,4(1HN),3X,2HAA,8X,
     5 2HAA,8X,2H**,/,21X,2H**,8X,2HAA,8X,2HAA,3X,2HDD,7X,2HDD,9X,2HII,
     6 8X,2HNN,7X,3HNNN,3X,2HAA,8X,2HAA,8X,2H**,/,21X,2H**,8X,2HAA,8X,
     7 2HAA,3X,10(1HD),5X,12(1HI),3X,2HNN,8X,2HNN,3X,2HAA,8X,2HAA,8X,
     8 2H**,/,21X,2H**,8X,2HAA,8X,2HAA,3X,9(1HD),6X,12(1HI),3X,2HNN,9X,
     9 1HN,3X,2HAA,8X,2HAA,8X,2H**,/,2(21X,2H**,88X,2H**,/),
     A 21X,2H**,23X,43HREFERENCE- ADINA ENGINEERING REPORT AE 81-1,22X,
     B 2H**,/2(21X,2H**,88X,2H**,/),21X,92(1H*),/21X,92(1H*),///)
 2006 FORMAT (45X,46HTHIS PROGRAM IS IN ITS ENTIRETY PROPRIETARY TO/,
     1        48X,44H   AND IS SUPPORTED AND MAINTAINED BY        //,
     1        51X,31HADINA ENGINEERING AB   (SWEDEN) ,/,
     2        51X,31HADINA ENGINEERING INC  (USA)    ,//,
     3        38X,40HADINA ENGINEERING MAKES NO WARRANTY WHAT ,
     4        21HSOEVER , EXPRESSED OR ,/,
     5        38X,40HIMPLIED, THAT THE PROGRAM AND ITS DOCUME ,
     6        21HNTATION INCLUDING ANY ,/,
     7        38X,40HMODIFICATIONS AND UPDATES ARE FREE FROM  ,
     8        21HERRORS AND DEFECTS.IN ,/,
     9        38X,40HNO EVENT  SHALL  ADINA ENGINEERING  BECO ,
     9        21HME LIABLE TO THE USER )
 2007 FORMAT (38X,40HOR ANY PARTY FOR ANY LOSS , INCLUDING BU ,
     1        21HT NOT LIMITED TO LOSS ,/,
     2        38X,40HOF TIME , MONEY OR GOODWILL , WHICH MAY   ,
     3        21HARISE FROM THE USE OF ,/,
     4        38X,40HTHE PROGRAM AND ITS DOCUMENTATION INCLUD ,
     5        21HING ANY MODIFICATIONS ,/,38X,12HAND UPDATES.    //
     6        21X,20HADINA ENGINEERING AB,51X,21HADINA ENGINEERING INC/
     7        21X,13HMUNKGATAN 20D,58X,15H71 ELTON AVENUE   /
     8        21X,8HS-722 12,63X,9HWATERTOWN                /
     9        21X,16HVASTERAS  SWEDEN,55X,18HMASSACHUSETTS  USA   /
     A        21X,16HTEL 021-14 40 50,55X,18HTEL [phone]  /
     B        21X,19HTELEX 40630 ADINA S      //)
 2010 FORMAT (////40X,40H *  E N D   O F   D A T A   P R I N T  * )
 2020 FORMAT (1H1,46H P R I N T   O U T   F O R   T I M E   S T E P ,I5,
     1 40X,12H ( AT TIME  ,E10.4,2H ) )
 2025 FORMAT (/84H ( NODAL RESPONSES PRINTED ARE MEASURED IN THE SKEW CO
     1ORDINATE SYSTEM OF EACH NODE )   )
 2030 FORMAT(////41H  D A T A   C H E C K   C O M P L E T E D)
 2040 FORMAT (//// 64H STOP BECAUSE OUT-OF-BALANCE LOADS LARGER THAN INC
     1REMENTAL LOADS )
 2050 FORMAT (/2X,44HNO EQUILIBRIUM ITERATION IN THIS TIME STEP       )
 2060 FORMAT (/1X,I5,79H EQUILIBRIUM ITERATIONS PERFORMED IN THIS TIME
     1STEP TO REESTABLISH EQUILIBRIUM  )
 2070 FORMAT (2X,48HSTIFFNESS REFORMED FOR THIS TIME STEP            )
 2080 FORMAT (2X,42HSTIFFNESS NOT REFORMED FOR THIS TIME STEP         )
 2090 FORMAT (1H1,44H S O L U T I O N   T I M E   L O G (IN SEC) //12X,
     1        11HFOR PROBLEM//1X,18A4////)
 2100 FORMAT (49H INPUT PHASE  . . . . . . . . . . . . . . . . . .F9.2//
     A        49H SUBSTRUCTURES INPUT PHASE. . . . . . . . . . . .F9.2//
     1        49H ASSEMBLAGE OF LINEAR STIFFNESS,EFFECTIVE STIFF-      /
     2        49H NESS,MASS MATRICES AND LOAD VECTORS . . . . . . F9.2//
     3        49H FREQUENCY ANALYSIS . . . . . . . . . . . . . . .F9.2//
     B        49H INITIAL CALCULATIONS FOR MODE SUPERPOSITION        /
     C        49H                      ANALYSIS . . . . . . . . . F9.2//
     4        49H TRIANGULARIZATION OF LINEAR (EFFECTIVE)          /
     +        49H                      STIFFNESS MATRIX  . . . . .F9.2//
     6            )
 2110 FORMAT (
     5        24H STEP-BY-STEP SOLUTION (,I5,12H TIME STEPS)          //
     6        43H    CALCULATION OF EFFECTIVE LOAD VECTORS .      ,F9.2/
     7        43H    UPDATING EFFECTIVE STIFFNESS MATRICES             /
     8        43H      AND LOAD VECTORS FOR NONLINEARITIES .      ,F9.2/
     9        43H    SOLUTION OF EQUATIONS . . . . . . . . .      ,F9.2/
     A        43H    EQUILIBRIUM ITERATIONS  . . . . . . . .      ,F9.2/
     +        43H    DIVERGENCE PROCEDURE  . . . . . . . . .      ,F9.2/
     B        43H    CALCULATION AND PRINTING OF DISPLACE-             /
     C        43H      MENTS, VELOCITIES, AND ACCELERATIONS       ,F9.2/
     D        43H    CALCULATION AND PRINTING OF STRESSES  .      F9.2//
     E        49H                               STEP-BY-STEP TOTALF9.2//
     F        49H CALCULATION AND PRINTING OF SUBSTRUCTURE            /
     G        16X,33H INTERNAL RESPONSES . . . . . . .,F9.2/////,
     F        49H T O T A L   S O L U T I O N   T I M E (SEC). . .,F9.2)
 2290 FORMAT (//15H  STEP NUMBER =,I5,5X,12H ( AT TIME  ,E10.4,2H )  )
 2300 FORMAT (////69H TIMING INFORMATION FOR THE SOLUTION OF EQUATIONS F
     1OR THE FIRST STEP ,//45H  TIME AT ENTERING THE EQUATION SOLVER
     2  =, F10.2)
 2310 FORMAT (45H  TIME AT THE END OF SOLUTION OF EQUATIONS  =,F10.2)
 2320 FORMAT (//39H CONDITIONING OF THE COEFFICIENT MATRIX,//,
     154H LARGEST ELEMENT OF THE UNFACTORED STIFFNESS MATRIX  =,E15.5/,
     254H SMALLEST ELEMENT OF THE UNFACTORED STIFFNESS MATRIX =,E15.5/,
     354H LARGEST DIAGONAL ELEMENT OF THE FACTORIZED MATRIX   =,E15.5/,
     454H SMALLEST DIAGONAL ELEMENT OF THE FACTORIZED MATRIX  =,E15.5//)
 2330 FORMAT (///38H *** STRUCTURAL MODEL IS UNSTABLE *** //
     1           38H RATIO OF LARGEST TO SMALLEST DIAGONAL  ,
     2           50H ELEMENTS IN FACTORIZED STIFFNESS MATRIX GT 1.E+11/)
      END
C *UNI* )FOR,IS N.SECOND,R.SECOND
      SUBROUTINE SECOND (TIM)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     CALL TIMING (TIM)
      RETURN
      END
C ***** OVL00
C *CDC* *DECK SHTADV
C *UNI* )FOR,IS N.SHTADV, R.SHTADV
      SUBROUTINE SHTADV (A,B,C,AA,NN,IIND)
C
C     IIND.EQ.1     SUBROUTINE CALCULATES  A = B - C
C     IIND.EQ.2     SUBROUTINE CALCULATES  A = B + C
C     IIND.EQ.3     SUBROUTINE CALCULATES  A = A - B*C*AA
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),C(1)
C
      GO TO (5,15,25),IIND
C
    5 DO 10 I=1,NN
   10 A(I)=B(I) - C(I)
      RETURN
C
   15 DO 20 I=1,NN
   20 A(I)=B(I) + C(I)
      RETURN
C
   25 DO 30 I=1,NN
   30 A(I)=A(I) - B(I)*C(I)*AA
      RETURN
C
      END
C *CDC* *DECK SUBSTR
C *UNI* )FOR,IS N.SUBSTR, R.SUBSTR
      SUBROUTINE SUBSTR
C
C . . . . . . . . . . . . . .  . . .   . . . . . . . . . .  . . . . . .
C .                                                                   .
C .      . PROGRAM                                                    .
C .          TO PERFORM SUBSTRUCTURE ANALYSIS                        .
C .                                                                   .
C .      IND=0, READ NODAL/ELEMENT DATA                               .
C .             CHECK FOR HIGH SPEED STORAGE AVAILABILITY             .
C .             MODIFY COLUMN HEIGHTS OF MASTER NODES                 .
C .                                                                   .
C .      IND=1, ASSEMBLE LINEAR MATRICES FOR SUBSTRUCTURES            .
C .             MODIFY MASTER STIFFNESS MATRIX                        .
C .                                                                   .
C .      IND=2, ASSEMBLE SUBSTRUCTURE LOAD VECTORS                    .
C .             MODIFY MASTER LOADS                                   .
C .                                                                   .
C .      IND=4, CALCULATE DISPLACEMENTS AT CONDENSED DOF              .
C .             CALCULATE AND PRINT-OUT STRESSES                      .
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 /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMN/ N3A,N4A,N4B,N4C
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      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 /SUBSTF/ NREC16
      COMMON /SLOA/ N09C,ITMFN,ICOORD,NUSE
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /STORES/ MXTMPS,MDVAS,MXSTHS,MXNEQS,MXBLCS,MXNN1
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SKEW/ NSKEWS
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /MDFRDM/ IDOF(6)
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /LOACHK/ LSC
      COMMON /DPR/ ITWO
      COMMON /RANDAC/ NR(5),LR(5)
      COMMON /SRANDI/ N09A,N09B
      COMMON /PRGCON/ ICPRI,NTU
      COMMON /BLOCKS/ NSREFB,NEQITB,NPRIB,NODSVB,LEMSVB,ISREFB(3,10),
     1                IEQITB(3,10),IPRIB(3,10),INODB(3,10),IELMB(3,10)
C
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      DATA ICASE / 0 /
C
      IF (IND.NE.0) GO TO 400
C
      IF (ICASE.NE.0) GO TO 5
      ICASE=1
      NR(3)=190
      NR(4)=190
      LR(3)=3000
      LR(4)=3000
      DEFINE FILE 16 (190,3000,U,IDUM)
      DEFINE FILE 17 (190,3000,U,NDUM)
    5 CONTINUE
C
      REWIND NSTAPE
C
C     SHIFT MASTER STRUCTURE COLUMN HEIGHTS INTO A LOWER STORAGE
C
      N09A=N1
      N09B=N09A + NDOF*NUMNP
      N1=N09B + NEQ
      DO 10 I=1,NEQ
   10 IA(N09B+I-1)=IA(N5+I-1)
C
      MAXES=0
      KRSIZM=0
C
C     SAVE SOME MASTER CONTROL INFORMATION
C
      CALL LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,NPSHS,
     1             NODE3S,1)
      IGTEMP=ITEMPR
      NI=NBCEL
      MAXMST=MAXMSS
      NBLOCT=0
C
C
C     I N P U T   P H A S E
C
C
      IF (IDATWR.LE.1) WRITE (6,2000)
      DO 300 NSUB=1,NSUBST
      NBCEL=0
      MAXMSS=0
      MIDIND=0
C
C     CALL ADINI TO READ/GENERATE DATA FOR EACH SUBSTRUCTURE
C
C *CDC*      CALL OVERLAY (5HADINA,1,0,6HRECALL)
      CALL ADINI
C
C     CLEAR ARRAY FOR CALCULATION OF SUBSTRUCTURE COLUMN HEIGHTS
C
      NN=N5 + NEQS - 1
      DO 20 I=N5,NN
   20 IA(I)=0
      N6=N5 + NEQS
      N08=N1B
      N09=N1C
C
C     READ ELEMENT GROUPS DATA
C
      CALL ELCAL (NEGLS,NEGNLS,MAXES,ISUB)
C
C     COMPUTE MAXA ARRAY
C
      N09C=N1
      N1=N09C + NDOFS*NUMNPS
      IF (IOPE.NE.3) CALL ADDRES (A(N1),A(N5),NEQS,NWKS,MAS)
C
C     TEST FOR AVAILABILITY OF HIGH SPEED STORAGE AND CALCULATE
C     MAXIMUM BLOCKSIZE, NUMBER OF BLOCKS AND BLOCK COUPLING
C
      LSC=0
      NDISCE=0
      CALL STORE (NUMNPS,NDOFS,NEQS,NWKS,MAS,NEGNLS,MAXES,NBLOCS,
     1            ISTOHS,1)
C
      NN=N07 + 8*(NSUB - 1)
      IA(NN  )=NEQS
      IA(NN+1)=NWKS
      IA(NN+2)=MAXES
      IA(NN+3)=NBCEL
      IA(NN+4)=NBLOCS
      IA(NN+5)=ISTOHS
      IA(NN+6)=NEQC
      IA(NN+7)=NTUSE
C
C     IN A DYNAMIC ANALYSIS, CALCULATE STORAGE NEEDS
C
      IF (ISTAT.EQ.0) GO TO 80
      IF (NEQS.GT.MXNEQS) MXNEQS=NEQS
      MDVAS=MDVAS + NEQS*NTUSE
      MTMPS=NEQS + 1 + NBLOCS + NBLOCS
      IF (MTMPS.GT.MXTMPS) MXTMPS=MTMPS
      IF (ISTOHS.GT.MXSTHS) MXSTHS=ISTOHS
      IF (NBLOCS.GT.MXBLCS) MXBLCS=NBLOCS
      NN1=NDOFS*NUMNPS
      IF (NN1.GT.MXNN1 .AND. IPRIC.NE.0) MXNN1=NN1
   80 CONTINUE
      NBLOCT=NBLOCT + NBLOCS + 1
      NN=N1C - 1
      WRITE (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1               NDOFS,(IA(I),I=N1,NN)
C
C     READ CONNECTIVITY ARRAYS
C
      M1=N09C
      M2=M1 + NDOFS*NUMNPS
      M3=M2 + NODRET
      M4=M3 + NODRET*NDOF
C
      DO 100 M=1,NTUSE
C
      CALL MODMHT (M,A(N09A),A(N09B),A(M1),A(M2),A(M3),NDOF,NDOFS,NUMNP)
C
  100 CONTINUE
C
  300 CONTINUE
C
C     REINSTATE MASTER LOAD CONTROL INFORMATION
C
      CALL LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,NPSHS,
     1             NODE3S,3)
C
C     RESET ADDRESS OF MASTER STRUCTURE COLUMN HEIGHTS
C
      N1=N09A
      N5=N09B
      NBCEL=NI
      ITEMPR=IGTEMP
      MAXMSS=MAXMST
      MIDIND=MAXMST
      N08=N07 + 8*NSUBST
      N09=N08 + MIDIND
C
      RETURN
C
  400 IF (IND - 2) 410,500,600
C
C
C     A S S E M B L A G E   O F   S T I F F N E S S   M A T R I C E S
C
C
  410 NN=N2 - 1
      WRITE (NSTAPE) (IA(I),I=N1,NN)
      REWIND NSTAPE
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      NBLOC1=NBLOCT + 1
      N09A=N1
      N1=N09A + NBLOC1
C *CDC*      CALL OPENMS (16,IDUM,1,0)
C *IBM*     DEACTIVATE THE ABOVE 1 CARD FOR  IBM
      DO 412 I=1,NBLOC1
      J=N09A + I - 1
  412 IA(J)=0
C *CDC*      CALL STINDX (16,IA(N09A),NBLOC1,0)
C
C *IBM*      DEACTIVATE THE ABOVE CARD FOR  IBM
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      REWIND 1
      IF (NEGL.EQ.0) GO TO 425
      DO 420 I=1,NEGL
  420 READ (1)
  425 NREC16=0
C
      REWIND 11
      REWIND 18
      REWIND 23
      READ (23)
      READ (23)
      DO 450 NSUB=1,NSUBST
C
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
C
      N1A=N1 + NEQS + 1
      N1B=N1A + NBLOCS
      N1C=N1B + NBLOCS
      N1D=N1C
      N2=N1D
      N3=N2 + ISTOHS*ITWO
      N4=N3 + ISTOHS*ITWO
      IF (NBLOCS.EQ.1 .AND. IMASS.LT.2) N4=N3
      N5=N4 + NEQS*ITWO
      IF (ISTAT.EQ.0) N5=N4 + NEQC*ITWO
      N6=N5 + NEQS*ITWO
      IF (ISTAT.EQ.0) N6=N5
      N7=N6 + MAXES + NBCEL
      CALL SIZE (N7)
C
      NN=N1C - 1
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1              NDOFS,(IA(I),I=N1,NN)
C
C     ENTIRE SUBSTRUCTURE STIFFNESS MATRIX IS TEMPORARILY WRITTEN ONTO
C     TAPE 12
C
      CALL ASSEM (A(N1),A(N2),A(N3),A(N4),A(N5),A(N5),A(N6),A(N1A),
     1            A(N4),A(N1C),A(N6),A(N04),A(N05),ISTOHS,NBLOCS)
      IND=1
C
C     REDUCE STIFFNESS MATRIX. L, D FACTORS ARE WRITTEN ONTO TAPE16.
C
      CALL COLSOL (A(N1),A(N1A),A(N1B),A(N2),A(N3),A(N4),A(N4),A(N04),
     1             NEQS,NBLOCS,ISTOHS,12,16,1)
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      NREC16=NREC16 + NBLOCS + 1
      CALL WRITMS (16,A(N4),NEQC,NREC16,-1)
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      NRD=NEQS - NEQC
      KRSIZE=NRD*(NRD + 1)/2
      N3=N2 + KRSIZE*ITWO
C
      CALL SUBSKR (A(N2),A(N3),A(N3),A(N3),A(N1),A(N1A),ISTOHS,NBLOCS,
     1             NREC16,NREC17,KRSIZE,NEQ)
C
  450 CONTINUE
C
      IF (ISTAT.GT.0) GO TO 460
      READ (NSTAPE)
      NN=N1 - 1
      WRITE (NSTAPE) (IA(I),I=N09A,NN)
      BACKSPACE NSTAPE
      BACKSPACE NSTAPE
C
      N1=N09A
  460 N1A=N1 + NEQ + 1
      N1B=N1A + NBLOCK
      N1C=N1B + NBLOCK
      N1D=N1C + NBLOCK*NEGNL
      IF (NBLOCK.EQ.1) N1D=N1C
      N1S=N1D + (IEIG + 1)*NBLOCK + 1
      N2=N1S + MXTMPS
      NN=N1S - 1
      READ (NSTAPE) (IA(I),I=N1,NN)
      CALL STORE (NUMNP,NDOF,NEQ,NWK,MA,NEGNL,MAXEST,NBLOCK,ISTOH,1)
C
      RETURN
C
C
C     L O A D   V E C T O R   C A L C U L A T I O N
C
C
  500 NN=N2 - 1
      IF (MODEX.GT.0 .AND. ISTAT.EQ.0) READ (NSTAPE)
      IF (ISTAT.GT.0) BACKSPACE NSTAPE
      WRITE (NSTAPE) (IA(I),I=N1,NN)
      BACKSPACE NSTAPE
C
C     ALLOCATE STORAGE FOR READING IN TIME FUNCTIONS, RANDOM ACCESS
C     INFORMATIONS FOR TAPE16, TAPE17
C
      IF (ISTAT.EQ.0) N09A=N1
      NBLOC1=NBLOCT + 1
      N09B=N09A + NBLOC1
      IF (MODEX.EQ.0) GO TO 505
      IF (ISTAT.GT.0) GO TO 505
      NN=N09B - 1
      BACKSPACE NSTAPE
      READ (NSTAPE) (IA(I),I=N09A,NN)
  505 REWIND NSTAPE
C
      NREC17=0
      DO 510 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1) + 7
      NTUSE=IA(NN)
  510 NREC17=NREC17 + NTUSE
      NREC17=NREC17*NSTE + NSTE + 1
      N09C=N09B + NREC17
      IF (MODEX.EQ.0) GO TO 515
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
C *CDC*      CALL OPENMS (17,NDUM,1,0)
C            DEACTIVATE THE ABOVE CARD FOR  IBM
      DO 512 I=1,NREC17
      J=N09B + I - 1
  512 IA(J)=0
C *CDC*      CALL STINDX (17,IA(N09B),NREC17,0)
C            DEACTIVATE THE ABOVE CARD FOR  IBM
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
  515 N1=N09C + NTFN*(NSTE + 1 + 2*NPTM)*ITWO + NTFN
C
      NREC16=0
      ITMFN=0
C
C     ASSEMBLE SUBSTRUCTURE LOAD VECTORS AND ADD TO MASTER LOADS
C
      DO 550 NSUB=1,NSUBST
      ICOORD=0
C
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
C
      N1A=N1 + NEQS + 1
      N1B=N1A + NBLOCS
      N1C=N1B + NBLOCS
      N1D=N1C
      N2=N1D
      N3=N2 + ISTOHS*ITWO
      N4=N3 + NEQS*ITWO
      N5=N4 + NEQ*ITWO
      N6=N5 + NODRET*NDOF
      NN=N1C - 1
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1              NDOFS,(IA(I),I=N1,NN)
C
      KRSIZE=NEQS
      CALL SUBSKR (A(N3),A(N2),A(N4),A(N5),A(N1),A(N1A),ISTOHS,NBLOCS,
     1             NREC16,NREC17,KRSIZE,NEQ)
C
      NREC16=NREC16 + NBLOCS + 1
  550 CONTINUE
C
      IF (MODEX.EQ.0) GO TO 560
      IF (ISTAT.GT.0) GO TO 560
      READ (NSTAPE)
      READ (NSTAPE)
      READ (NSTAPE)
      NN=N09C - 1
      WRITE (NSTAPE) (IA(I),I=N09B,NN)
      BACKSPACE NSTAPE
      BACKSPACE NSTAPE
C
  560 N1=N09A
      IF (ISTAT.GT.0) N1=N09C
      N1A=N1 + NEQ + 1
      N1B=N1A + NBLOCK
      N1C=N1B + NBLOCK
      N1D=N1C + NBLOCK*NEGNL
      IF (NBLOCK.EQ.1) N1D=N1C
      N1S=N1D + (IEIG + 1)*NBLOCK + 1
      N2=N1S + MXTMPS
      NN=N2 - 1
      READ (NSTAPE) (IA(I),I=N1,NN)
C
C     CHANGE STARTING LOCATION OF INDEX ARRAY FOR
C     TAPE 10 SINCE N1D HAS BEEN CHANGED
C
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      IF (IOPE.EQ.3) GO TO 575
      NBLOC1=(IEIG + 1)*NBLOCK + 1
C *CDC*      CALL STINDX (10,IA(N1D),NBLOC1,0)
C            DEACTIVATE THE ABOVE CARD FOR  IBM
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
  575 CONTINUE
C
      RETURN
C
C
C     T I M E   I N T E G R A T I O N   F O R   S U B S T R U C T U R E
C
C
  600 IF (NSTE.EQ.0) GO TO 900
      IF (KSTEP.EQ.0) GO TO 900
      IND=4
      ICOUNT=2
      ITE=0
      KLINSV=KLIN
      KLIN=0
      ITEMPR=0
      ITP96=0
      IEQREF=0
      NPDIS=0
      NDISCE=0
      NMIDSS=0
      MIDIND=0
      MAXMSS=MIDIND
      NEGNLS=0
      NSTET=KSTEP
C
C
C     FOR STATIC ANALYSIS CALCULATE INTERNAL DISPLACEMENTS
C
C
      IF (ISTAT.GT.0) GO TO 856
C
C     TRANSFER MASTER DISPLACEMENTS FROM TAPE15 TO TAPE3
C
      NT=15
      DO 630 K=1,NSTET
  630 BACKSPACE NT
      REWIND 3
      NN=N1 + (NEQ+ILOA(12))*ITWO - 1
      DO 635 K=1,NSTET
      READ (NT) (A(I),I=N1,NN)
      WRITE (3) (A(I),I=N1,NN)
  635 CONTINUE
C
      IF (ISTAT.EQ.0) N09A=N1
      NBLOC1=NBLOCT + 1
      N09B=N09A + NBLOC1
      NN=N09B - 1
      BACKSPACE NSTAPE
      BACKSPACE NSTAPE
      READ (NSTAPE) (IA(I),I=N09A,NN)
      READ (NSTAPE)
C
      NREC17=0
      DO 610 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1) + 7
      NTUSE=IA(NN)
  610 NREC17=NREC17 + NTUSE
      NREC17=NREC17*NSTE + NSTE + 1
      N09C=N09B + NREC17
      NN=N09C - 1
      READ (NSTAPE) (IA(I),I=N09B,NN)
      REWIND NSTAPE
      REWIND 23
      NREC16=0
      NREC17=NSTE
      N1=N09C
C
      IMASS=0
      IVC=0
      IAC=0
C
C     RESPONSE OF INDIVIDUAL SUBSTRUCTURES
C
      DO 850 NSUB=1,NSUBST
C
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
C
      N1A=N1 + NEQS + 1
      N1B=N1A + NBLOCS
      N1C=N1B + NBLOCS
      N1D=N1C
      N2=N1D
      NN=N1C - 1
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1              NDOFS,(IA(I),I=N1,NN)
C
C     STORAGE CALCULATIONS
C
      CALL STORE (NUMNPS,NDOFS,NEQS,NWKS,MAS,NEGNLS,MAXES,NBLOCS,
     1            ISTOHS,2)
C
C     READ L AND D FACTORS OF STIFFNESS MATRIX INTO CORE
C
      IF (NBLOCS.NE.1) GO TO 645
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      KK=NREC16 + 1
      CALL READMS (16,A(N4),ISTOHS,KK)
C
  645 KK=NREC16 + NBLOCS + 1
      CALL READMS (16,A(N4B),NEQC,KK)
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
C     RESPONSE OF REPEATED SUBSTRUCTURES
C
      DO 800 M=1,NTUSE
C
      KSTEP=0
      TIME=TSTART
      TIMEP=TSTART
      REWIND 3
C
C
C     T I M E   S T E P   I N C R E M E N T A T I O N
C
C        KSTEP .EQ. STEP COUNTER
C        TIME .EQ. TIME AT WHICH SOLUTION IS REQUIRED
C
C
  700 KSTEP=KSTEP + 1
      TIMEP=TIME + DTA
      TIME=TIME + DT
C
C     READ MASTER DISPLACEMENTS FROM TAPE15
C
      NN=N4 - 1
      READ (3) (A(I),I=N3,NN)
      NREC17=NREC17 + 1
C
C     EXTRACT DISP AT RETAINED DOF FROM MASTER DOF DISPLACEMENTS
C
      KRSIZE=NEQS
      CALL SUBSKR (A(N2),A(N4),A(N3),A(N6),A(N1),A(N1A),ISTOHS,NBLOCS,
     1             NREC16,NREC17,KRSIZE,NEQ)
C
C
C     CALCULATE INTERNAL DISPLACEMENTS
C
  701 CALL COLSOL (A(N1),A(N1A),A(N1B),A(N4),A(N4A),A(N4B),A(N2),
     1             A(N04),NEQS,NBLOCS,ISTOHS,12,16,3)
      CALL WRITMS (17,A(N2),NEQS,NREC17,-1)
  750 IF (KSTEP.LT.NSTET) GO TO 700
C
      IF (NSTET.EQ.NSTE) GO TO 800
      NREC17=NREC17 + NSTE - NSTET
C
  800 CONTINUE
C
      NREC16=NREC16 + NBLOCS + 1
C
  850 CONTINUE
C
C     WRITE DISPLACEMENTS ON TAPE 23
C
      DO 855 KSTEP=1,NSTET
      NREC17=KSTEP
      DO 855 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NTUSE=IA(NN+7)
      DO 855 M=1,NTUSE
      NREC17=NREC17 + NSTE
      CALL READMS (17,A(N2),NEQS,NREC17)
      NN=N2 + NEQS*ITWO - 1
  855 WRITE (23) (A(I),I=N2,NN)
C
  856 REWIND 23
      TIME=TSTART
      TIMEP=TSTART
      KSTEP=0
  860 KSTEP=KSTEP + 1
      REWIND NSTAPE
C
C     POSITION TAPE1 CONTAINING SUBSTRUCTURE ELEMENT GROUP DATA
C
      REWIND 1
      IF (NEGL.EQ.0) GO TO 864
      DO 863 I=1,NEGL
  863 READ (1)
  864 REWIND 15
      DO 865 I=1,NTFN
  865 READ (15)
      TIMEP=TIMEP + DTA
      TIME=TIME + DT
C
C     FLAGS FOR SAVING NODAL AND ELEMENT RESPONSES
C
C     KPLOTN.EQ.0  FOR SAVING NODAL DISP, VEL, ACC VECTORS
C     KPLOTE.EQ.0  FOR SAVING ELEMENT RESPONSES
C
      CALL BLKCNT (KSTEP,NODSVB,KPLOTN,INODB,NSTE,4)
      CALL BLKCNT (KSTEP,LEMSVB,KPLOTE,IELMB,NSTE,5)
C
      DO 885 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
      IREAD=0
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,(IDOFS(I),I=1,6),
     1              NDOFS
      N2=N1
C
C     STORAGE CALCULATIONS
C
      CALL STORE (NUMNPS,NDOFS,NEQS,NWKS,MAS,NEGNLS,MAXES,NBLOCS,
     1            0,2)
      NN=N5 + NDOFS*NUMNPS - 1
      READ (15) (IA(I),I=N5,NN)
      READ (15)
      READ (15)
      READ (15)
      DO 880 M=1,NTUSE
C
C     READ SUBSTRUCTURE DISPLACEMENTS,VELOCITIES,ACCELERATIONS
C
      NN=N2 + NEQS*ITWO - 1
      READ (23) (A(I),I=N2,NN)
      IF (ISTAT.EQ.0) GO TO 866
      NN=N7 + NEQS*ITWO - 1
      READ (23) (A(I),I=N7,NN)
      NN=N8 + NEQS*ITWO - 1
      READ (23) (A(I),I=N8,NN)
  866 IND=5
      CALL SUBSKR (A(N2),A(N4),A(N3),A(N6),A(N1),A(N1A),ISTOHS,NBLOCS,
     1             NREC16,NREC17,KRSIZE,NEQ)
      IND=4
      IF (KPRI.NE.0) KPRI = KPLOTE
      IF (IPRI.NE.0) GO TO 867
      ICPRI=3
      WRITE (6,2020) KSTEP,TIME,NSUB,M
      IF (NSKEWS.LE.0) GO TO 867
      WRITE (6,2025)
      ICPRI=ICPRI + 2
C
C     PRINT SUBSTRUCTURE RESPONSES
C
  867 CALL WRITE (A(N1),A(N2),A(N7),A(N8),A(N5),IDOFS,ISUB,NEQS,NDOFS,2)
C
C     CALCULATE AND PRINT STRESSES
C
      IF (KPRI.NE.0) GOTO 880
      IF (IREAD.EQ.0) GO TO 869
      DO 868 I=1,NEGLS
  868 BACKSPACE 1
  869 CALL STRESS (A(N10),ISUB,NEGLS,NEGNLS)
      IREAD=1
  880 CONTINUE
      IREAD=0
  885 CONTINUE
      IF (KSTEP.LT.NSTET) GO TO 860
      KLIN=KLINSV
  900 CONTINUE
C
C *CDC*  900 CALL STINDX (16,IDUM,1,0)
C *CDC*      CALL CLOSMS (16)
C *CDC*      CALL STINDX (17,NDUM,1,0)
C *CDC*      CALL CLOSMS (17)
C
      RETURN
C
 2000 FORMAT (1H1,34HS U B S T R U C T U R E   D A T A ,///)
 2020 FORMAT (1H1,46H P R I N T   O U T   F O R   T I M E   S T E P ,I5,
     1 7X,26H ( SUBSTRUCTURE RESPONSE ),7X,12H ( AT TIME  ,E10.4,2H ),//
     2 22H SUBSTRUCTURE NUMBER =,I5,20X,28H IDENTIFICATION SET NUMBER =,
     3 I5)
 2025 FORMAT (/84H ( NODAL RESPONSES PRINTED ARE MEASURED IN THE SKEW CO
     1ORDINATE SYSTEM OF EACH NODE )   )
C
      END
C *CDC* *DECK STORE
C *UNI* )FOR,IS N.STORE, R.STORE
      SUBROUTINE STORE (NUMNP,NDOF,NEQ,NWK,MA,NEGNL,MAXEST,NBLOCK,ISTOH,
     1                  KKK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   PROGRAM.                                                        .
C .      TO ALLOCATE STORAGE IN BLANK COMMON DURING DIFFERENT         .
C .      PHASES OF THE ANALYSIS                                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMP,MEQ,NWA,NWM,NWC,NUMEST,MIDEST,MAXSET,NSTE,MAA
      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,NENGL,IMASS,IDAMP,ISTAT
     1           ,NDOM,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 /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /LOACHK/ LSC
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /SKEW/ NSKEWS
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      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 /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
C
      COMMON /DPR/ ITWO
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMN/ N3A,N4A,N4B,N4C
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1           N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /FREQIF/ ISTOW,N1A,N1B,N1C,N1S
      COMMON /STORES/ MXTMPS,MDVAS,MXSTHS,MXNEQS,MXBLCS,MXNN1
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MPRNT/ IOUTPT,ISTPRT
C
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
C
      NEQT=NEQ + NDISCE
      IF (KKK - 1) 1, 2, 100
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   STORAGE OF ARRAYS PERMANENTLY STORED IN-CORE                    .
C .                                                                   .
C . ADDRESS   LENGTH         VARIABLE                                 .
C .                                                                   .
C .    N0     NEGNL          LENGTHS OF ELEMENT GROUPS                .
C .    N0A    NEGNL + 1      RANDOM ACCESS INFORMATION                .
C .    N01    NDISCE         NID                                      .
C .    N02    NDISCE*NIDM    IDI                                      .
C .    N03  NDISCE*NIDM*ITWO BETA                                     .
C .    N04    NPDIS          NOD                                      .
C .    N05    NPDIS*ITWO     PRDIS                                    .
C .    N06    9*NSKEWS*ITWO  RSDCOS                                   .
C .    N07    8*NSUBST       STORAGE SIZES FOR SUBSTRUCTURES          .
C .    N08   MIDSS   MID-SURFACE NODES INDICATOR                      .
C .                  STORAGE WILL BE ALLOCATED IN ADINI AND ADINA     .
C .    N09   FMIDSS  NORMAL VECTORS AT MID-SURFACE NODES              .
C .    N010  FMV1    V1 VECTORS AT MID-SURFACE NODES                  .
C .                  STORAGE WILL BE ALLOCATED IN ADINI AND ADINA     .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
    1 N0A=N0 + NEGNL
      N01=N0A + NEGNL + 1
      N02=N01 + NDISCE
      N03=N02 + NDISCE*NIDM
      N04=N03 + NDISCE*NIDM*ITWO
      N05=N04 + NPDIS
      N06=N05 + NPDIS*ITWO
      N07=N06 + 9*NSKEWS*ITWO
      N08=N07 + 8*NSUBST
      N1=N08
      RETURN
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   TEST FOR AVAILABILITY OF HIGH SPEED STORAGE AND CALCULATE       .
C .   MAXIMUM BLOCKSIZE, NUMBER OF BLOCKS, AND BLOCK COUPLING         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C       1. STORAGE FOR LOAD VECTOR CALCULATIONS
C
    2 IF (IND.GT.0) GO TO 50
      IF (ISUB.EQ.0) GO TO 3
      IF (LSC.EQ.0) GO TO 31
    3 MSTORE=N1 + NEQ + (NEQ + (2*NPTM+NSTE+1)*NTFN)*ITWO + NTFN + 100
      IF (NSTE.GT.0) MSTORE=MSTORE + NDOF*NUMNP
      IF (ISUB.EQ.0 .AND. NSKEWS.GT.0) MSTORE=MSTORE + NUMNP
      MMC=4*NLOAD + 2*NLOAD*ITWO
      MMP=3*NUMNP*ITWO + 12*NPR2*ITWO + 15*NPR2
      IF (NPR2.GT.0 .AND. MMP.GT.MMC) MMC=MMP
      MMP=3*NUMNP*ITWO + (3*NODE3 + 5)*NPR3*ITWO + (4*NODE3 + 3)*NPR3
      IF (NPR3.GT.0 .AND. MMP.GT.MMC) MMC=MMP
      MMP=(3*NUMNP*ITWO)+(15*NPBM*ITWO)+(19*NPBM)
      IF(NPBM.GT.0 .AND. MMP.GT.MMC)MMC=MMP
      MMP=NEQ*ITWO
      IF (IDGRAV.GT.0 .AND. MMP.GT.MMC) MMC=MMP
      MMP=2*NPDIS*ITWO + 4*NPDIS
      IF (MMP.GT.MMC) MMC=MMP
      MMP=2*NTEMP*ITWO + 3*NTEMP
      IF (MMP.GT.MMC) MMC=MMP
      MSTORE=MSTORE + MMC
      IF (ISTPRT.GT.0)
     *  WRITE (6,2200)
      CALL SIZE(MSTORE)
      IF (ISUB.GT.0) RETURN
C
C       2. STORAGE FOR MATRIX ASSEMBLAGE PHASE AND TIME INTEGRATION
C
C     CENTRAL DIFFERENCE METHOD
C
    4 IF (IOPE.NE.3) GO TO 5
      ISV=(IVC + JVC + 1)/2
      ISA=(IAC + JAC + 1)/2
      MSTORE=N1 + (3 + ISV + ISA)*NEQT*ITWO + ITEMPR*(NUMNP + 1)*ITWO
      MTEMP=NDOF*NUMNP
      IF (MTEMP.LT.NEQ*ITWO) MTEMP=NEQ*ITWO
      MSTORE=MSTORE + MTEMP + MAXEST + NBCEL
      NBLOCK=1
      ISTOH=0
      IF (MSTORE.LE.MTOT) GO TO 45
      IF (ISTPRT.GT.0)
     *  WRITE (6,3000)
      CALL SIZE (MSTORE)
C
C     STATIC ANALYSIS AND IMPLICIT TIME INTEGRATION
C
    5 MSTORE=N1 + 2*NEQT*ITWO + ITEMPR*(NUMNP + 1)*ITWO + MAXEST + NBCEL
      MSTORE=MSTORE + NEQ*ITWO
      IF (NLSTPD.GT.0 .OR. METHOD.EQ.2) MSTORE=MSTORE + NEQT*ITWO
      MTEMP=2*NEQT*ITWO
      IF (MTEMP.LT.(NDOF*NUMNP)) MTEMP=NDOF*NUMNP
      MSTORE=MSTORE + MTEMP
      IF (IMODES.EQ.0 .AND. IMASS.EQ.1) MSTORE=MSTORE + NEQ*ITWO
      IF (ISTAT.EQ.1) MSTORE=MSTORE + 2*NEQT*ITWO
      N1A=N1 + NEQ + 1
      N1B=N1A + NEQ
      IBLOCK=4
      NBLOCK=1
      MTEMP=0
      IF (IMODES.EQ.0) GO TO 10
      MTEMP=8*NMODES*ITWO
      IF (KLIN.GT.0 .AND. (NEGL.GT.0 .OR. NSUBST.GT.0))
     *    MTEMP=MTEMP + (NMODES + 1)*NMODES*ITWO/2
   10 MELST=NEQ + 1 + (3 + IEIG + NEGNL)*IBLOCK + 1
      IF (MELST.GT.MTEMP) MTEMP=MELST
      ISTORL=(MTOT - MSTORE - MTEMP)/ITWO
      IF (ISTOTE.GT.0) ISTORL=ISTOTE
      IF (ISTORL.GT.0) GO TO 15
      WRITE (6,3010)
      STOP
C
   15 CALL SBLOCK (A(N1),A(N1A),A(N1B),ISTORL,NBLOCK,NEQ,NWK,ISTOH)
C
      IF (ISTOTE.GT.0) GO TO 20
   16 IF (NBLOCK.LE.IBLOCK) GO TO 20
      IBLOCK=IBLOCK*2
      IF (IBLOCK.LT.1000) GO TO 10
      WRITE (6,3020)
      STOP
   20 N2=N1 + MTEMP
C
C     3. SPECIAL CASES
C       (1) MULTIPLE BLOCK CASE AND SUBSTRUCTURES ARE USED
C
      IF (NSUBST.EQ.0) GO TO 25
      IF (NBLOCK.EQ.1) GO TO 22
      IF (KRSIZM.LE.ISTOH) GO TO 25
      MM=2*(KRSIZM - ISTOH)*ITWO + 1000
      IF (ISTOTE.GT.0) MM=MM - 1000
      WRITE (6,3030) MM
      STOP
C
C       (2) ONE BLOCK CASE AND SUBSTRUCTURES ARE USED
C
   22 MM=N2 + 2*NEQ*ITWO + MAXEST + NBCEL
      MSTORE=MM + ISTOH*ITWO + KRSIZM*ITWO
      IF (MTOT.GE.MSTORE) GO TO 25
      MSTORE=(MTOT - (MM + KRSIZM*ITWO))/ITWO
      IF (MSTORE.LT.ISTORL) ISTORL=MSTORE
      NBLOCK=2
      CALL SBLOCK (A(N1),A(N1A),A(N1B),ISTORL,NBLOCK,NEQ,NWK,ISTOH)
C
C       (3) ONE BLOCK CASE AND CONSISTENT MASS MATRIX IS USED
C
   25 IF (IMASS.NE.2 .OR. NBLOCK.GT.1) GO TO 30
      MM=N2 + 2*ISTOH*ITWO + 2*NEQ*ITWO + MAXEST + NBCEL
      IF (MM.LE.MTOT) GO TO 30
      NBLOCK=2
      CALL SBLOCK (A(N1),A(N1A),A(N1B),ISTORL,NBLOCK,NEQ,NWK,ISTOH)
C
C        4. STORAGE FOR FREQUENCY ANALYSIS
C
   30 IF (IEIG.EQ.0) GO TO 35
      IF (IESTYP.EQ.0)
     * MSTORE=N2 + 9*NEQ*ITWO + 4*(NFREQ + 3)*ITWO + NFREQ + 4
      NP=MIN0(2*NFREQ,NFREQ + 8)
      NCM=NQ
      IF (NQ.LT.NP) NCM=MIN0(NFREQ + NQ/2,NFREQ + 8)
      IF (IESTYP.EQ.1)
     * MSTORE=N2 + (NQ + 3)*NEQ*ITWO + NQ*(2*NQ + 6)*ITWO + NCM*ITWO
     *           + NCM + NQ + 150
      IF (IMASS.EQ.1) MSTORE=MSTORE + NEQ*ITWO
      MM=(MTOT - MSTORE)/ITWO
      IF (NBLOCK.GT.1 .OR. IMASS.EQ.2) MM=MM/2
      IF (MM.GE.ISTOH) GO TO 35
      IF (NBLOCK.GT.1 .OR. IMASS.EQ.2) MM=2*MM
      NBLOCK=2
      CALL SBLOCK (A(N1),A(N1A),A(N1B),MM,NBLOCK,NEQ,NWK,ISTOH)
      GO TO 35
C
C     STORAGE CALCULATIONS FOR SUBSTRUCTURE ANALYSIS
C
   31 MSTORE=N1 + (NEQ + MEQ+ILOA(12) + NEQC)*ITWO + MAXEST + NBCEL +
     *       NDOF*NUMNP + NEQ-NEQC + 1000
      N1A=N1 + NEQ + 1
      N1B=N1A + NEQ
      IBLOCK=4
      NBLOCK=1
   32 MELST=NEQ + 1 + 2*IBLOCK
      ISTORL=(MTOT - MSTORE - MELST)/ITWO
      IF (ISTOTE.GT.0) ISTORL=ISTOTE
      CALL SBLOCK (A(N1),A(N1A),A(N1B),ISTORL,NBLOCK,NEQ,NWK,ISTOH)
      IF (ISTOTE.GT.0) GO TO 33
      IF (NBLOCK.LE.IBLOCK) GO TO 33
      IBLOCK=IBLOCK*2
      IF (IBLOCK.LT.1000) GO TO 32
      WRITE (6,3020)
      STOP
C
   33 NRD=NEQ - NEQC
      KRSIZE=NRD*(NRD + 1)/2
      N2=N1 + MELST
      MM=N2 + (ISTOH + KRSIZE)*ITWO
      IF (MM.LE.MTOT) GO TO 35
      NBLOCK=2
      ISTORL=2*(MTOT - N2 - KRSIZE*ITWO)/ITWO
      CALL SBLOCK (A(N1),A(N1A),A(N1B),ISTORL,NBLOCK,NEQ,NWK,ISTOH)
C
C     WRITE MASTER/SUBSTRUCTURE TOTAL SYSTEM DATA
C
   35 CONTINUE
      MAM=NWK/NEQ
      IF (NWK.GT.MAM*NEQ) MAM=MAM + 1
      IF (ISUB.EQ.0) WRITE (6,2203)
      IF (ISUB.GT.0) WRITE (6,2206)
      WRITE (6,2210) NEQ,NWK,MA,MAM,ISTOH,NBLOCK,MTOT
      WRITE (6,2220)
      NN=N1A + NBLOCK - 1
      WRITE (6,2230) (I,I=1,NBLOCK)
      WRITE (6,2240) (IA(I),I=N1A,NN)
      NN=N1B + NBLOCK - 1
      WRITE (6,2250) (IA(I),I=N1B,NN)
      NN=N1A + NBLOCK
      DO 40 I=1,NBLOCK
   40 IA(NN+I-1)=IA(N1B+I-1)
      N1B=NN
      N1C=N1B + NBLOCK
      N1D=N1C + NBLOCK*NEGNL
      IF (NBLOCK.EQ.1) N1D=N1C
      N2=N1D + (IEIG + 1)*NBLOCK + 1
   45 IF (IOPE.EQ.3) N2=N1
      IF (ISUB.GT.0) RETURN
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   A S S E M B L A G E   O F   L I N E A R   M A T R I C E S       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
   50 N3=N2 + ISTOH*ITWO
      N4=N3 + ISTOH*ITWO
      IF (NBLOCK.EQ.1 .AND. IMASS.LT.2) N4=N3
      IF (NSUBST.EQ.0) GO TO 70
      IF (NBLOCK.EQ.1 .AND. IMASS.LT.2) GO TO 65
      IF (KRSIZM.LT.ISTOH) GO TO 70
   65 N4=N3 + KRSIZM*ITWO
   70 N5=N4 + NEQ*ITWO
      N6=N5 + NEQ*ITWO
      IF (IMASS.EQ.0) N6=N4
      IF (ISTAT.EQ.0 .AND. IDGRAV.EQ.1) N6=N5
      N7=N6 + MAXEST + NBCEL
      IF (ISTPRT.GT.0)
     *  WRITE (6,2260)
      CALL SIZE(N7)
      RETURN
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   S T O R A G E   F O R   T I M E   I N T E G R A T I O N         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  100 IF (ISUB.GT.0) GO TO 200
      IF (IOPE.EQ.3) N2=N1 + NEQT*ITWO
      IF (IMODES.EQ.0) GO TO 110
      MTEMP=8*NMODES*ITWO
      IF (KLIN.GT.0 .AND. (NEGL.GT.0 .OR. NSUBST.GT.0))
     *    MTEMP=MTEMP + (NMODES + 1)*NMODES*ITWO/2
      IF (MTEMP.LE.(N2 - N1)) GO TO 110
      N2=N1 + MTEMP
  110 N3=N2 + NEQT*ITWO + MDVAS*ITWO
      N3A=N3 + NEQT*ITWO + MDVAS*ITWO
      N4=N3A + NEQT*ITWO
      IF (NLSTPD.EQ.0 .AND. METHOD.EQ.1) N4=N3A
      N4A=N4 + ISTOH*ITWO
      IF (MXSTHS.GT.ISTOH) N4A=N4 + MXSTHS*ITWO
      N4B=N4A + ISTOH*ITWO
      IF (NBLOCK.EQ.1) N4B=N4A
      IF (MXBLCS.LE.1) GO TO 116
      MXTEMP=MXSTHS*ITWO
      IF (MXTEMP.GT.(N4B-N4A)) N4B=N4A + MXTEMP
  116 N4C=N4B + NEQ*ITWO
      N5=N4C + MXNEQS*ITWO
      IF (IOPE.EQ.3) GO TO 120
C
      N6=N5 + NEQT*ITWO
      IF (MXNEQS.GT.NEQT) N6=N5 + MXNEQS*ITWO
      N6A=N6 + NEQT*ITWO
      IF (MXNEQS.GT.NEQT) N6A=N6 + MXNEQS*ITWO
      NN1=NDOF*NUMNP
      IF (MXNN1.GT.NN1) NN1=MXNN1
      NN2=N6A - N5
      IF (NN1.GT.NN2) N6A=N5 + NN1
      GO TO 140
C
  120 NN1=NDOF*NUMNP
      NN2=NEQT*ITWO
      IF (NN2.GT.NN1) NN1=NN2
      N6=N5
      N6A=N6 + NN1
C
  140 IF (IMODES.EQ.0) GO TO 145
      IF (KLIN.EQ.0 .OR. (NEGL.EQ.0 .AND. NSUBST.EQ.0)) GO TO 145
      MTEMP=NMODES*(NMODES + 1)*ITWO/2
      IF (MTEMP.GT.(N6A-N5)) N6A=N5 + MTEMP
  145 N6B=N6A + (ITEMPR - 1)*(NUMNP + 1)*ITWO
      N7=N6B + (NUMNP+1)*ITWO
      IF (IOPE.EQ.3) GO TO 150
C
      N8=N7 + NEQT*ITWO + MDVAS*ITWO
      N9=N8 + NEQT*ITWO + MDVAS*ITWO
      N10=N9 + NEQ*ITWO + MXNEQS*ITWO
      IF (NSTE.EQ.0 .AND. IEIG.EQ.1) N10=N9
      IF (IMODES.GT.0) N10=N9
      IF (IMASS.EQ.2) N10=N9
      IF (ISTAT.EQ.0) N10=N7
      GO TO 160
C
  150 N8=N7 + NEQT*ITWO
      IF (IVC.EQ.0 .AND. JVC.EQ.0) N8=N7
      N9=N8 + NEQT*ITWO
      IF (IAC.EQ.0 .AND. JAC.EQ.0) N9=N8
      N10=N9
C
  160 N11=N10 + MAXEST + NBCEL
      IF (ISTPRT.GT.0)
     *  WRITE (6,2280)
      CALL SIZE (N11)
      RETURN
C
C     STORAGE ALLOCATION DURING TIME INTEGRATION FOR SUBSTRUCTURES
C
  200 N3=N2 + NEQ*ITWO
      N4=N3+(MEQ+ILOA(12))*ITWO
      N4A=N4 + ISTOH*ITWO
      N4B=N4A + ISTOH*ITWO
      IF (NBLOCK.EQ.1) N4B=N4A
      N5=N4B + NEQC*ITWO
      N6=N5 + NDOF*NUMNP
      N7=N6 + NEQ - NEQC
      N8=N7 + NEQ*ITWO
      N9=N8 + NEQ*ITWO
      N10=N9
      N11=N10 + MAXEST + NBCEL
      IF (ISTPRT.GT.0)
     *  WRITE (6,2280)
      CALL SIZE (N11)
      RETURN
C
 2200 FORMAT (//30H STORAGE CHECK FOR LOAD INPUT )
 2203 FORMAT (1H1,20HTOTAL SYSTEM DATA            //)
 2206 FORMAT (1H1,25HSUBSTRUCTURE SYSTEM DATA        //)
 2210 FORMAT (5X,
     255HNUMBER OF EQUATIONS . . . . . . . . . . . . . .(NEQ)  =,I8//5X,
     355HNUMBER OF MATRIX ELEMENTS . . . . . . . . . . .(NWK)  =,I8//5X,
     455HMAXIMUM HALF BANDWIDTH . . . . . . . . . . . . (MA )  =,I8//5X,
     555HMEAN HALF BANDWIDTH . . . . . . . . . . . . . .(MAM)  =,I8//5X,
     655HMAXIMUM BLOCK LENGTH . . . . . . . . . . . . (ISTOH)  =,I8//5X,
     755HNUMBER OF BLOCKS . . . . . . . . . . . . . .(NBLOCK)  =,I8//5X,
     855HMAXIMUM TOTAL STORAGE AVAILABLE. . . . . . .( MTOT )  =,I8//)
 2220 FORMAT(/4X,51H NUMBER OF COLUMNS PER BLOCK AND 1ST COUPLING BLOCK)
 2230 FORMAT (//6X,16H NUMBER OF BLOCK,12X,(15I5,/34X))
 2240 FORMAT (6X,28H NUMBER OF COLUMNS PER BLOCK,(15I5,/,34X))
 2250 FORMAT (6X,21H FIRST COUPLING BLOCK,7X,(15I5,/,34X))
 2260 FORMAT (//50H0**STORAGE CHECK FOR ASSEMBLAGE OF LINEAR MATRICES )
 2280 FORMAT (//50H0**STORAGE CHECK FOR TIME INTEGRATION PHASE        )
C
 3000 FORMAT(//53H STORAGE CHECK FOR TIME INTEGRATION                  )
 3010 FORMAT (//60H  ** STOP ** NO STORAGE AVAILABLE TO STORE STIFFNESS
     1MATRIX. ,/68H INCREASE MTOT AND/OR BREAK ELEMENTS INPUT INTO MORE
     2ELEMENT GROUPS.   )
 3020 FORMAT (// 22H STOP  ERROR IN INPUT   //
     1           38H MORE THAN 1000 SOLUTION BLOCKS REQD   )
 3030 FORMAT (1H1////,43H SOLUTION STOP DUE TO INSUFFICIENT STORAGE ,/,
     1 62H AN OUT-OF-CORE SOLUTION IS REQUIRED FOR THE MASTER STRUCTURE
     2/62H AND THE REDUCED SUBSTRUCTURE STIFFNESS MATRIX IS LARGER THAN
     3 50HONE BLOCK OF THE MASTER STIFFNESS MATRIX.
     4/56H HENCE EITHER INCREASE THE BLANK COMMON SIZE AT LEAST BY,I8,
     5/68H OR DECREASE THE RETAINED NUMBER OF DOF FOR THE LARGEST SUBSTR
     6UCTURE    ///)
C
      END
C *CDC* *DECK SIZE
C *UNI* )FOR,IS  N.SIZE,   R.SIZE
      SUBROUTINE SIZE(N)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON A(1)
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /MPRNT/ IOUTPT,ISTPRT
      REAL A
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     THE OPTION OF MTOT.EQ.0 MUST BE VERIFIED BY THE USER ON THE
C     MACHINE USED
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      IF(MTOT.NE.0) GO TO 10
C
C *CDC*       LPROG=LOCF(A)
C *UNI*       LPROG=LOC (A)
C  10 LCORE=LPROG+N+10
C     MTOT=N
C     CALL XRFL (LCORE)
C
   10 IF (N.LT.(MTOT+10)) GO TO 20
      WRITE (6,1000)
      WRITE (6,1001) N
      WRITE (6,1004)
      STOP
   20 IF (ISTPRT.EQ.0) RETURN
      WRITE (6,1000)
      WRITE (6,1001) N
      WRITE (6,1008)
      RETURN
 1000 FORMAT(/,4X,35HCORE INFORMATION . . . (DECIMAL). .     )
 1001 FORMAT(     4X,20H    REQUESTED CORE=  ,5X,I6    )
 1004 FORMAT (    4X,24H    NOT AVAILABLE  STOP  )
 1008 FORMAT(     4X,20H    OBTAINED . . .        //)
      END
C *CDC* *DECK GAUSSD
C *UNI* )FOR,IS  N.GAUSSD, R.GAUSSD
      BLOCK DATA
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     EVAL2 - STRESS OUTPUT LOCATION USED IN STRESS TABLES
C             ( 2-D ELEMENTS )
C     EVAL3 - STRESS OUTPUT LOCATION USED IN STRESS TABLES
C             ( 3-D ELEMENTS )
C
C     XG    - GAUSS INTEGRATION POINTS IN THE INTERVAL (-1,1)
C     WGT   - GAUSS INTEGRATION WEIGHTS
C             ( XG,WGT USED FOR ISOPARAMETRIC ELEMENTS )
C
C     TRAPS - TRAPEZOIDAL RULE INTEGRATION POINTS IN THE INTERVAL
C             (-1, 1) FOR PERIODIC FUNCTIONS
C     GATES - FIRST 4 COLUMNS FOR GAUSS INTEGRATION
C             COLS 5,6,7 - CLOSED NEWTON-COTES FOR 3,5,7 POINTS IN THE
C             INTERVAL (-1,1)
C     WATES - WEIGHTS FOR GATES
C             ( TRAPS,GATES,WATES USED FOR BEAM ELEMENTS )
C             ( GATES, WATES USED FOR ISO/BEAM ELEMENTS )
C
C     TRLW4 -  4 POINTS TRIANGULAR INTEGERATION
C     TRLW7 -  7 POINTS TRIANGULAR INTEGERATION
C     TRLWD - 13 POINTS TRIANGULAR INTEGERATION
C         L1=A1/A , STORED IN THE FIRST COLUMN
C         L2=A2/A , STORED IN THE SECOND COLUMN
C         TRWT=TRIANGULAR WEIGHT , STORED IN THE THIRD COLUMN
C             ( TRLW4,TRLW7,TRLWD USED FOR TRIANGULAR SHELL EL. )
C
C     HAMMS - HAMMER INTEGRATION FORMULAS FOR TRIANGLES
C             PSIV= A2/A,   ETAV= A3/A,   WGTV= WEIGHT
C             ( PSIV,ETAV,WGTV USED FOR PLATE ELEMENTS )
C
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /PIE/ PI,TOPI,DEGRAD,RADEG
      COMMON /GASNEW/ TRAPS(12,3),GATES(7,7),WATES(7,7)
      COMMON /TRANG/ TRLW4(4,3),TRLW7(7,3),TRLWD(13,3),
     1               XGRS(16,2),WGTRS(16)
      COMMON /HAMMS / PSIV(14),ETAV(14),WGTV(14)
      COMMON /ICA/ IC(16,3),NCOL,IBC,NC
C
C *CDC*       DATA PI,TOPI/ 3.141592653590, 6.283185307180 /
C *CDC*       DATA DEGRAD,RADEG/ .0174532925199, 57.29577951308 /
C
C *CDC*       DATA EVAL2 / 1.0,-1.0,-1.0, 1.0, 0.0,-1.0, 0.0, 1.0, 0.0,
C *CDC*      1             1.0, 1.0,-1.0,-1.0, 1.0, 0.0,-1.0, 0.0, 0.0/
C
C *CDC*       DATA EVAL3 /
C *CDC*      1     1.,-1.,-1., 1., 1.,-1.,-1., 1., 0.,-1., 0., 1.,
C *CDC*      1     0.,-1., 0., 1., 1.,-1.,-1., 1., 0., 0.,-1., 0.,
C *CDC*      2     1., 0., 0.,
C *CDC*      3     1., 1.,-1.,-1., 1., 1.,-1.,-1., 1., 0.,-1., 0.,
C *CDC*      4     1., 0.,-1., 0., 1., 1.,-1.,-1., 0., 1., 0.,-1.,
C *CDC*      5     0., 0., 0.,
C *CDC*      6     1., 1., 1., 1.,-1.,-1.,-1.,-1., 1., 1., 1., 1.,
C *CDC*      7    -1.,-1.,-1.,-1., 0., 0., 0., 0., 0., 0., 0., 0.,
C *CDC*      8     0., 1.,-1. /
C
C *CDC*       DATA XG /     0.,             0.,             0., 0.,
C *CDC*      1 -.5773502691896, .5773502691896,             0., 0.,
C *CDC*      2 -.7745966692415, .0000000000000, .7745966692415, 0.,
C *CDC*      3 -.8611363115941,-.3399810435849, .3399810435849,
C *CDC*      4  .8611363115941 /
C
C *CDC*       DATA WGT / 2.000,             0.,             0., 0.,
C *CDC*      1 1.0000000000000,1.0000000000000,             0., 0.,
C *CDC*      2  .5555555555556, .8888888888889, .5555555555556, 0.,
C *CDC*      3  .3478548451375, .6521451548625, .6521451548625,
C *CDC*      4  .3478548451375 /
C
C
C *CDC*       DATA TRAPS /-1., -.5, 0., .5, 8*0.,
C *CDC*      1            -1., -.5, 0., .5, -.75, -.25, .25, .75, 4*0.,
C *CDC* 2            -1., -.5, 0., .5, -.8333333333333, -.6666666666667,
C *CDC* 3            -.3333333333333,  -.1666666666667,  .1666666666667,
C *CDC* 4             .3333333333333,   .6666666666667,  .8333333333333
C
C *CDC*       DATA GATES / 0., 6*0.,
C *CDC*      1 -.5773502691896, .5773502691896, 5*0.,
C *CDC*      2 -.7745966692415, .0000000000000, .7745966692415, 4*0.,
C *CDC*      3 -.8611363115941,-.3399810435849, .3399810435849,
C *CDC*      4  .8611363115941, 3*0.,
C *CDC*      5 -1., 1., 0., 4*0.,   -1., 1., 0., -.5, .5, 2*0.,
C *CDC*      6  -1., 1., 0., -.3333333333333, .3333333333333,
C *CDC*      7  -.6666666666667, .6666666666667 /
C
C *CDC*       DATA WATES / 2.0, 6*0.,
C *CDC*      1 1.0000000000000,1.0000000000000, 5*0.,
C *CDC*      2  .5555555555556, .8888888888889, .5555555555556, 4*0.,
C *CDC*      3  .3478548451375, .6521451548625, .6521451548625,
C *CDC*      4  .3478548451375, 3*0.,
C *CDC*      5  .3333333333333, .3333333333333, 1.333333333333, 4*0.,
C *CDC*      6  2*.1555555555556, .2666666666667, 2*.7111111111111, 2*0.
C *CDC*      6  2*.0976190476190, .6476190476190, 2*.0642857142857,
C *CDC*      7  2*.5142857142857 /
C
C *CDC*       DATA TRLW4/  .2,  .2,  .3333333333333,  .6,
C *CDC*      1             .2,  .6,  .3333333333333,  .2,
C *CDC*      2        .5208333333333,  .5208333333333, -.5625000000000,
C *CDC*      3        .5208333333333/
C
C *CDC*  DATA TRLW7/  .1012865073235,  .0597158717898,  .1012865073235,
C *CDC* 1             .4701420641051,  .3333333333333,  .4701420641051,
C *CDC* 2             .7974269853531,
C *CDC* 3             .1012865073235,  .4701420641051,  .7974269853531,
C *CDC* 4             .0597158717898,  .3333333333333,  .4701420641051,
C *CDC* 5             .1012865073235,
C *CDC* 6             .1259391805448,  .1323941527885,  .1259391805448,
C *CDC* 7             .1323941527885,  .2250000000000,  .1323941527885,
C *CDC* 8             .1259391805448/
C
C *CDC*  DATA TRLWD/  .0651301029022,  .0486903154253,  .0486903154253,
C *CDC* 1             .0651301029022,  .3128654960049,  .2603459660790,
C *CDC* 2             .2603459660790,  .3128654960049,  .6384441885698,
C *CDC* 3             .3333333333333,  .4793080678419,  .6384441885698,
C *CDC* 4             .8697397941956,
C *CDC* 5             .0651301029022,  .3128654960049,  .6384441885698,
C *CDC* 6             .8697397941956,  .0486903154253,  .2603459660790,
C *CDC* 7             .4793080678419,  .6384441885698,  .0486903154253,
C *CDC* 8             .3333333333333,  .2603459660790,  .3128654960049,
C *CDC* 9             .0651301029022,
C *CDC* A             .0533472356088,  .0771137608903,  .0771137608903,
C *CDC* B             .0533472356088,  .0771137608903,  .1756152574332,
C *CDC* C             .1756152574332,  .0771137608903,  .0771137608903,
C *CDC* D            -.1495700444677,  .1756152574332,  .0771137608903,
C *CDC* E             .0533472356088/
C
C *CDC*  DATA PSIV/   .3333333333333,  .1666666666667,  .6666666666667,
C *CDC* 1             .1666666666667,  .5,  .5,  0.,
C *CDC* 2             .1012865073235,  .7974269853531,  .1012865073235,
C *CDC* 3             .4701420641051,  .4701420641051,  .0597158717898,
C *CDC* 4             .3333333333333/
C *CDC*  DATA ETAV/   .3333333333333,  .1666666666667,  .1666666666667,
C *CDC* 1             .6666666666667,  0.,  0.5,  0.5,
C *CDC* 2             .1012865073235,  .1012865073235,  .7974269853531,
C *CDC* 2             .0597158717898,  .4701420641051,  .4701420641051,
C *CDC* 3             .3333333333333/
C *CDC*  DATA WGTV/   1.,
C *CDC* 1             .3333333333333,  .3333333333333,  .3333333333333,
C *CDC* 2             .3333333333333,  .3333333333333,  .3333333333333,
C *CDC* 3             .1259391805448,  .1259391805448,  .1259391805448,
C *CDC* 4             .1323941527885,  .1323941527885,  .1323941527885,
C *CDC* 4             .225/
C
C     DATA FOR ARRAY IC  CAN BE USED FOR ALL VERSIONS
C
      DATA IC /1,2,6,7,8,12,14,9*0,
     1         1,2,3,4,5,6,7,8,9,10,11,12,15,16,0,0,
     2         1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/
C
      DATA PI,TOPI/ 3.141592653590D0, 6.283185307180D0/
      DATA DEGRAD,RADEG/ .0174532925199D0, 57.29577951308D0/
C
      DATA EVAL2 /1.0D0,-1.0D0,-1.0D0, 1.0D0, 0.0D0,-1.0D0,
     1    0.0D0,  1.0D0, 0.0D0, 1.0D0, 1.0D0,-1.0D0,-1.0D0,
     2    1.0D0,  0.0D0,-1.0D0, 0.0D0, 0.0D0/
C
      DATA EVAL3/ 1.0D0,-1.0D0,-1.0D0, 1.0D0, 1.0D0,-1.0D0,
     1    -1.0D0, 1.0D0, 0.0D0,-1.0D0, 0.0D0, 1.0D0,
     1     0.0D0,-1.0D0, 0.0D0, 1.0D0, 1.0D0,-1.0D0,-1.0D0,
     2     1.0D0, 0.0D0, 0.0D0,-1.0D0, 0.0D0,
     2     1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0,-1.0D0,-1.0D0,
     3     1.0D0, 1.0D0,-1.0D0,-1.0D0, 1.0D0, 0.0D0,-1.0D0,
     4     0.0D0, 1.0D0, 0.0D0,-1.0D0, 0.0D0, 1.0D0, 1.0D0,
     4    -1.0D0,-1.0D0, 0.0D0, 1.0D0, 0.0D0,-1.0D0,
     5     0.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,
     6    -1.0D0,-1.0D0,-1.0D0,-1.0D0, 1.0D0, 1.0D0, 1.0D0,
     7     1.0D0,-1.0D0,-1.0D0,-1.0D0,-1.0D0, 0.0D0, 0.0D0,
     8     0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
     8     0.0D0, 1.0D0,-1.0D0 /
C
      DATA XG /     0.D0,             0.D0,             0.D0,
     1             0.D0,-.5773502691896D0, .5773502691896D0,
     2              0.D0,             0.D0,-.7745966692415D0,
     3  .0000000000000D0, .7745966692415D0,             0.D0,
     4 -.8611363115941D0,-.3399810435849D0, .3399810435849D0,
     5  .8611363115941D0/
C
      DATA WGT / 2.000D0,     0.0D0,     0.0D0,     0.0D0,
     1 1.0000D0,1.000000D0, 0.0D0, 0.0D0, .5555555555556D0,
     2  .8888888888889D0, .5555555555556D0, 0.0D0,
     3  .3478548451375D0, .6521451548625D0, .6521451548625D0,
     4  .3478548451375D0/
C
      DATA TRAPS /  -1.D0, -.5D0,  0.D0,  .5D0,  8*0.D0,
     1              -1.D0, -.5D0,  0.D0,  .5D0, -.75D0, -.25D0,
     2              .25D0, .75D0,4*0.D0, -1.D0,  -.5D0,   0.D0,  0.5D0,
     3           -.8333333333333D0,-.6666666666667D0,-.3333333333333D0,
     4           -.1666666666667D0, .1666666666667D0, .3333333333333D0,
     5            .6666666666667D0, .8333333333333D0/
C
      DATA GATES / 0.D0,    6*0.D0,
     1           -.5773502691896D0, .5773502691896D0,           5*0.D0,
     2           -.7745966692415D0,   0.D0,  .7745966692415D0,  4*0.D0,
     3           -.8611363115941D0,-.3399810435849D0, .3399810435849D0,
     4            .8611363115941D0, 3*0.D0,  -1.D0, 1.D0, 0.D0, 4*0.D0,
     5           -1.D0,  1.D0,  0.D0, -.5D0,  .5D0,     2*0.D0,  -1.D0,
     6            1.D0,  0.D0,     -.3333333333333D0, .3333333333333D0,
     7           -.6666666666667D0, .6666666666667D0/
C
      DATA WATES / 2.D0,    6*0.D0,    1.D0,        1.D0,       5*0.D0,
     1            .5555555555556D0, .8888888888889D0, .5555555555556D0,
     2             4*0.D0,          .3478548451375D0, .6521451548625D0,
     3            .6521451548625D0, .3478548451375D0,           3*0.D0,
     4            .3333333333333D0, .3333333333333D0, .1333333333333D1,
     5             4*0.D0,        2*.1555555555556D0, .2666666666667D0,
     6             2*.7111111111111D0,    2*0.D0,   2*.0976190476190D0,
     7            .6476190476190D0,  2*.0642857142857D0,
     8             2*.5142857142857D0/
C
      DATA TRLW4/
     1     .2D0,.2D0,.3333333333333D0,.6D0,
     2     .2D0,.6D0,.3333333333333D0,.2D0,
     3     .5208333333333D0,.5208333333333D0,-.5625000000000D0,
     4     .5208333333333D0/
C
      DATA TRLW7/
     1     .1012865073235D0,.0597158717898D0,.1012865073235D0,
     2     .4701420641051D0,.3333333333333D0,.4701420641051D0,
     3     .7974269853531D0,
     4     .1012865073235D0,.4701420641051D0,.7974269853531D0,
     5     .0597158717898D0,.3333333333333D0,.4701420641051D0,
     6     .1012865073235D0,
     7     .1259391805448D0,.1323941527885D0,.1259391805448D0,
     8     .1323941527885D0,.2250000000000D0,.1323941527885D0,
     9     .1259391805448D0/
C
      DATA TRLWD/
     1     .0651301029022D0,.0486903154253D0,.0486903154253D0,
     2     .0651301029022D0,.3128654960049D0,.2603459660790D0,
     3     .2603459660790D0,.3128654960049D0,.6384441885698D0,
     4     .3333333333333D0,.4793080678419D0,.6384441885698D0,
     5     .8697397941956D0,
     6     .0651301029022D0,.3128654960049D0,.6384441885698D0,
     7     .8697397941956D0,.0486903154253D0,.2603459660790D0,
     8     .4793080678419D0,.6384441885698D0,.0486903154253D0,
     9     .3333333333333D0,.2603459660790D0,.3128654960049D0,
     A     .0651301029022D0,
     B     .0533472356088D0,.0771137608903D0,.0771137608903D0,
     C     .0533472356088D0,.0771137608903D0,.1756152574332D0,
     D     .1756152574332D0,.0771137608903D0,.0771137608903D0,
     E    -.1495700444677D0,.1756152574332D0,.0771137608903D0,
     F     .0533472356088D0/
C
      DATA PSIV / .3333333333333D0, .1666666666667D0, .6666666666667D0,
     1            .1666666666667D0, .5D0, .5D0, 0.D0,
     2            .1012865073235D0, .7974269853531D0, .1012865073235D0,
     3            .4701420641051D0, .4701420641051D0, .0597158717898D0,
     4            .3333333333333D0/
C
      DATA ETAV / .3333333333333D0, .1666666666667D0, .1666666666667D0,
     1            .6666666666667D0, 0.D0, .5D0, .5D0,
     2            .1012865073235D0, .1012865073235D0, .7974269853531D0,
     3            .0597158717898D0, .4701420641051D0, .4701420641051D0,
     4            .3333333333333D0/
C
      DATA WGTV / 1.D0,
     1            .3333333333333D0, .3333333333333D0, .3333333333333D0,
     2            .3333333333333D0, .3333333333333D0, .3333333333333D0,
     3            .1259391805448D0, .1259391805448D0, .1259391805448D0,
     4            .1323941527885D0, .1323941527885D0, .1323941527885D0,
     5            .225D0/
C
      END
C *CDC* *DECK ELCAL
C *UNI* )FOR,IS  N.ELCAL,  R.ELCAL
      SUBROUTINE ELCAL (NEGL,NEGNL,MAXEST,ISUB)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALL THE APPROPRIATE ELEMENT ROUTINES FOR READING,      .
C .        GENERATING AND STORING THE ELEMENT DATA                    .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXSET,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NGEL,NGENL,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 /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /DVGREF/ INDMNO
      COMMON /MINDEX/ MITWO(2),MITEN(2)
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (NPAR(1),NPAR1), (NPAR(3),INDNL)
C
      MINPAR=1
      MAXPAR=13
      INDMNO=1
C
      NGL=0
      NGNL=0
      IF (ISUB.EQ.0) GO TO 20
      NUMELG=NEGL
      IGTEMP=0
      GO TO 95
C
   20 REWIND 1
      NUMELG=NUMEG
      IDTHF=0
      IGTEMP=0
      ITEMPR=0
C
C         * * * * *    R A N D O M A C C E S S       * * *
C
      NEGNL1=NEGNL + 1
      IF (KLIN.EQ.0) GO TO 95
C *CDC*      CALL OPENMS (2,MITWO,2,0)
C  * * * DEACTIVATE THE ABOVE CARD FOR  IBM
      DO 92 I=1,NEGNL1
      J=N0A + (I-1)
   92 IA(J)=0
C *CDC*      CALL STINDX (2,IA(N0A),NEGNL1,0)
C
C  * * * DEACTIVATE ABOVE CARD FOR IBM MACHINE
C
C
C     R E A D I N   A L L   E L E M E N T   G R O U P S   I N F O
C
C
   95 IF (NUMELG.EQ.0) RETURN
      IF (IDATWR.GT.1) GO TO 98
      IF (ISUB.EQ.0) WRITE (6,2000)
      IF (ISUB.GT.0) WRITE (6,2010)
C
   98 DO 100 IG=1,NUMELG
      NG=IG
C
      ITEMPR=0
C
      READ(5,1000) NPAR
C
      NN=1
      IF (INDNL.GT.0) NN=2
      IF (INDNL.GT.1) INDMNO=0
      IF (NPAR1.GE.MINPAR .AND. NPAR1.LE.MAXPAR) GO TO 125
      WRITE (6,3100) NG,NPAR1,MINPAR,MAXPAR
      STOP
C
  125 IF (NG.NE.1 .AND. IDATWR.LE.1) WRITE (6,2005)
      IF (NN.EQ.1) NGL=NGL + 1
      IF (NN.EQ.2) NGNL=NGNL + 1
      IF (NGL.GT.NEGL .OR. NGNL.GT.NEGNL)
     *WRITE (6,3030) NEGL,NEGNL,NGL,NGNL
C
      IF (IDATWR.GT.1) GO TO 35
      IF (NN.EQ.1) WRITE (6,2011) NG
      IF (NN.EQ.2) WRITE(6,2012) NG
C
C
   35 CALL ELEMNT
C
      IF (ITEMPR.GT.IGTEMP) IGTEMP=ITEMPR
C
      IF (MIDEST.GT.MAXEST) MAXEST=MIDEST
C
      IF (NN.EQ.2) GO TO 90
      WRITE (NN) MIDEST,(A(I),I=NFIRST,NLAST)
      GO TO 100
C
C         * * * * *    R A N D O M A C C E S S       * * *
C
   90 IA(N0 + NGNL - 1)=MIDEST
      NREC2=NGNL
      CALL WRITMS (2,A(NFIRST),MIDEST,NREC2,-1)
C
C         * * * * *    R A N D O M A C C E S S       * * *
C
  100 CONTINUE
C
      ITEMPR=IGTEMP
C
      IF (ISTPRT.GT.0) WRITE (6,2040) MAXEST
C
      IF (NGL.EQ.NEGL .AND. NGNL.EQ.NEGNL) RETURN
      WRITE (6,3030) NEGL,NEGNL,NGL,NGNL
      STOP
C
 1000 FORMAT (20I4)
 2000 FORMAT (1H1,36HE L E M E N T   G R O U P   D A T A ///)
 2010 FORMAT (1H1,62HS U B S T R U C T U R E   E L E M E N T   G R O U P
     1   D A T A  ///)
 2005 FORMAT (1H1)
 2011 FORMAT (27H E L E M E N T   G R O U P ,27(1H.),2H =,I5,4X,
     1        10H( LINEAR )///)
 2012 FORMAT (27H E L E M E N T   G R O U P ,27(1H.),2H =,I5,4X,
     1        13H( NONLINEAR )///)
 2040 FORMAT (////49H MAX  ( LENGTH OF ARRAYS USED FOR STORING ELEMENT/
     1        51H GROUP DATA ) . . . . . . . . . . . .( MAXEST ) . =,I5)
 3030 FORMAT (1H1,42H **STOP  ERROR IN ELEMENT GROUP DATA INPUT,/,
     1        36H SPECIFIED NUMBER OF ELEMENT GROUPS-,I3,5H(LIN),I3,
     2        8H(NONLIN),/,29H BUT ELEMENT GROUPS READ ARE-,I3,5H(LIN),
     3        I3,8H(NONLIN) ,/1X)
 3100 FORMAT (///24H I N P U T   E R R O R -/
     1        29H DETECTED BY SUBROUTINE ELCAL//5X,
     2        16H ELEMENT GROUP =,I5/5X,10H NPAR(1) =,I5//5X,
     3        23H NPAR(1) SHOULD BE GE. ,I2, 9H AND LE. ,I2//8H S T O P)
C
      END
C *CDC* *DECK,COMPCT
C *UNI* FOR,IS N.COMPCT, R.COMPCT
      SUBROUTINE COMPCT (MIDSS,FMIDSS,MTEMP,DUMY)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .          TO    COMPACT THE MID-SURFACE NORMAL INDICATOR VECTOR,   .
C .                MIDSS, AND NORMAL VECTOR MATRIX, FMIDSS.           .
C .                ONLY NORMAL VECTORS RETATED TO MID-SURFACE NODES   .
C .                WHICH BELONG TO GEOMETRIC NONLINEAR ELEMENT GROUPS .
C .                ARE STORED                                         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
C
      DIMENSION MIDSS(1),FMIDSS(3,1),DUMY(3,1),MTEMP(1)
      DATA RECLB1/8HINORMALS/
      KK=0
      DO 10 I=1,NUMNP
      II=MIDSS(I)
      IF (II .EQ. 0) GO TO 10
      KK=KK + 1
      IF (II .GT. 0) GO TO 10
      J=-II
      MTEMP(J)=I
      DO 20 K=1,3
   20 DUMY(K,J)=FMIDSS(K,KK)
   10 CONTINUE
C
      DO 30 J=1,MIDIND
   30 MIDSS(J)=MTEMP(J)
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB1
      MIDIN3 = MIDIND * 3
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) RETURN
      IF (JDC.NE.0)
     1  WRITE (LUNODE) RECLAB,MIDIND,MIDIN3,(MIDSS(I),I=1,MIDIND),
     2  ((DUMY(I,J),I=1,3),J=1,MIDIN3)
C
C***  DATA PORTHOLE (END)
C
C
      RETURN
      END
C *CDC* *DECK ADDRES
C *UNI* )FOR,IS  N.ADDRES, R.ADDRES
      SUBROUTINE ADDRES (MAXA,MHT,NEQ,NWK,MA)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE ADDRESSES OF DIAGONAL ELEMENTS IN BANDED      .
C .        MATRIX WHOSE COLUMN HEIGHTS ARE KNOWN                      .
C .                                                                   .
C .        MHT  = ACTIVE COLUMN HEIGHTS                               .
C.         MAXA = ADDRESSES OF DIAGONAL ELEMENTS                      .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      DIMENSION MAXA(1),MHT(1)
C
      MAXA(1)=1
      MAXA(2)=2
      MA=0
      IF (NEQ.EQ.1) GO TO 100
      DO 10 I=2,NEQ
      IF (MHT(I).GT.MA) MA=MHT(I)
   10 MAXA(I+1)=MAXA(I) + MHT(I) + 1
  100 MA=MA + 1
      NWK=MAXA(NEQ+1) - MAXA(1)
C
      RETURN
      END
C *CDC* *DECK LOADSV
C *UNI* )FOR,IS N.LOADSV, R.LOADSV
      SUBROUTINE LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,
     1                   NPSHS,NODE3S,KKK)
C
C     SUBROUTINE TO SWITCH LOAD CONTROL INFORMATION
C
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /DISCON/ NDISCE,NIDM
      INTEGER ILOA(13)
C
      IF (KKK - 2) 1, 2, 3
C
C     SAVE MASTER LOAD CONTROL INFORMATION
C
    1 ILOA(1)=NLOAD
      ILOA(2)=NPR2
      ILOA(3)=NPR3
      ILOA(4)=NPBM
      ILOA(5)=NP3DB
      ILOA(6)=NPPL
      ILOA(7)=NPSH
      ILOA(8)=NODE3
      ILOA(9)=IDGRAV
      ILOA(10)=NPDIS
      ILOA(11)=NTEMP
      ILOA(12)=NDISCE
      ILOA(13)=NIDM
      GO TO 100
C
C     INTRODUCE SUBSTRUCTURE LOAD DATA
C
    2 NLOAD=NLOADS
      NPR2=NPR2S
      NPR3=NPR3S
      NPBM=NPBMS
      NP3DB=NP3DBS
      NPPL=NPPLS
      NPSH=NPSHS
      NODE3=NODE3S
      IDGRAV=IDGRAV
      NPDIS=0
      NTEMP=0
      NDISCE=0
      NIDM=0
      GO TO 100
C
C     REINSERT MASTER LOAD CONTROL INFORMATION
C
    3 NLOAD=ILOA(1)
      NPR2=ILOA(2)
      NPR3=ILOA(3)
      NPBM=ILOA(4)
      NP3DB=ILOA(5)
      NPPL=ILOA(6)
      NPSH=ILOA(7)
      NODE3=ILOA(8)
      IDGRAV=ILOA(9)
      NPDIS=ILOA(10)
      NTEMP=ILOA(11)
      NDISCE=ILOA(12)
      NIDM=ILOA(13)
C
  100 RETURN
C
      END
C *CDC* *DECK PRDINN
C *UNI* )FOR,IS N.PRDINN, R.PRDINN
      FUNCTION PRDINN (AA,BB,N)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   FUNCTION TO CALCULATE THE INNER PRODUCT OF VECTORS AA AND BB    .
C .   ACCOUNTING FOR PRESCRIBED DISPLACEMENT DEGREES OF FREEDOM       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
C
      COMMON A(1)
      INTEGER IA(1)
      DIMENSION AA(N),BB(N)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
      PRDINN=0.0
      IF (NPDIS.EQ.0) GO TO 50
      NP=1
      NN=IA(N04 + NP - 1)
      DO 20 I=1,N
      IF (I-NN) 15,10,15
   10 NP=NP + 1
      IF (NP.GT.NPDIS) GO TO 20
      NN=IA(N04 + NP - 1)
      GO TO 20
   15 PRDINN=PRDINN + AA(I)*BB(I)
   20 CONTINUE
      RETURN
C
   50 DO 100 I=1,N
  100 PRDINN=PRDINN + AA(I)*BB(I)
      RETURN
C
      END
C *CDC* *DECK ASSEM
C *UNI* )FOR,IS  N.ASSEM,  R.ASSEM
      SUBROUTINE ASSEM (MAXA,AA,CC,DD,BB,WV,EE,NCOLBV,TEMPV2,IGRBLC,
     1                  LMS,NOD,PRDIS,ISTOH,NBLOCK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO ASSEMBLE THE MATRICES NEEDED IN SOLUTION                .
C .                                                                   .
C .   E X E C U T I O N   M O D E                                     .
C .        IND=1   EFFECTIVE LINEAR STIFFNESS MATRIX IS ASSEMBLED     .
C .        IND=2   MASS MATRIX IS ASSEMBLED                           .
C .        IND=3   NONLINEAR STIFFNESS MATRIX IS ASSEMBLED            .
C .                FOR FREQUENCY ANALYSIS                             .
C .        IND=4   EFFECTIVE NONLINEAR STIFFNESS MATRIX IS ASSEMBLED  .
C .                AND EFFECTIVE LOAD VECTOR IS UPDATED               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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 /DISCON/ NDISCE,NIDM
      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 /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 /MSUPER/ IMODES,NMODES,IMDAMP
      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 /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /ADDB/ NEQL,NEQR,MLA,NTBLOK
      COMMON /DPR/ ITWO
      COMMON /ELSTP/ TIME,IDTHF
      COMMON A(1)
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
      REAL EE
      DIMENSION AA(ISTOH),BB(1),CC(ISTOH),DD(1),EE(1),WV(1),TEMPV2(1)
     1         ,LMS(1),NOD(1),PRDIS(1)
      INTEGER MAXA(1),NCOLBV(1),IGRBLC(NBLOCK,1)
C
C
C     B E F O R E   T I M E   I N T E G R A T I O N
C
      GO TO (10,100,600,300),IND
C
C     A S S E M B L A G E   O F   L I N E A R   M A T R I C E S
C
C
C       1. LINEAR STIFFNESS MATRIX IS ASSEMBLED AND STORED ON TAPE 4
C
   10 IF (IOPE.EQ.3) GO TO 100
      IF (NSUBST.EQ.0 .AND. NEGL.EQ.0) GO TO 100
      NEQL=1
      NEQR=0
      MLA=0
      NT=4
      IF (ISUB.GT.0 .AND. ISTAT.EQ.0) NT=12
      REWIND NT
C
      SMAX=0.
      SMIN=1.E50
      NEG=NEGL
      IF (ISUB.GT.0) NEG=NEGLS
      DO 20 L=1,NBLOCK
      NEQR=NEQR + NCOLBV(L)
      IF (ISUB.EQ.0) REWIND 1
      DO 30 I=1,ISTOH
   30 AA(I)=0.
C
      IF (NEG.EQ.0) GO TO 42
      DO 40 NG=1,NEG
      READ (1) NUMEST,(EE(I),I=1,NUMEST)
      CALL ELEMNT
   40 CONTINUE
C
   42 IF (ISUB.GT.0) GO TO 60
C
C     ADD SUBSTRUCTURE LINEAR STIFFNESS MATRICES
C
      IF (NSUBST.EQ.0) GO TO 49
      REWIND 18
      DO 47 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1) + 7
      NTUSE=IA(NN)
      DO 45 N=1,NTUSE
      READ (18) ND,(LMS(I),I=1,ND),KRSIZE,(CC(I),I=1,KRSIZE)
C
      CALL ADDBAN (AA,MAXA,CC,DD,LMS,ND,1)
C
   45 CONTINUE
   47 CONTINUE
C
   49 IF (KLIN.GT.0) GO TO 60
      DO 50 I=NEQL,NEQR
      II=MAXA(I) - MLA
      IF (AA(II).GT.SMAX) SMAX=AA(II)
      IF (AA(II).LT.SMIN) SMIN=AA(II)
   50 CONTINUE
C
   60 WRITE (NT) AA
      IF (ISUB.EQ.0) GO TO 80
      IF (L.EQ.NBLOCK) GO TO 80
      DO 70 I=1,NEG
   70 BACKSPACE 1
   80 NEQL=NEQL + NCOLBV(L)
      MLA=MAXA(NEQL) - 1
   20 CONTINUE
C
  100 CONTINUE
      IND=2
      IF (ISTAT.EQ.0 .AND. IDGRAV.EQ.0) RETURN
      IF (ISTAT.EQ.0 .AND. ISUB.EQ.1) RETURN
      NEG=NUMEG
      IF (ISUB.GT.0) NEG=NEGLS
      NEQU=NEQ
      IF (ISUB.GT.0) NEQU=NEQS
C
C       2. MASS MATRIX IS ASSEMBLED AND STORED ON TAPE 11
C
      IF (ISUB.EQ.0) REWIND 23
      IF (NSUBST.EQ.0) REWIND 11
      IF (ISTAT.GT.0) GO TO 112
      IMASS=1
  112 READ (23) (DD(I),I=1,NEQU)
      IF (ISTAT.GT.0) READ (23) (BB(I),I=1,NEQU)
C
      IF (IMASS.EQ.2) GO TO 110
C
C     2.1 LUMPED  MASS  MATRIX
C
      IF (ISUB.GT.0) GO TO 115
      REWIND 1
      GO TO 118
  115 DO 117 I=1,NEG
  117 BACKSPACE 1
  118 NN=1
C
      IF (NEG.EQ.0) GO TO 121
      DO 120 NG=1,NEG
      IF (ISUB.GT.0) GO TO 119
      IF (NG.GT.NEGL) NN=2
  119 IF (NN.EQ.1) READ(NN) NUMEST,(EE(I),I=1,NUMEST)
      IF (NN.EQ.1) GO TO 116
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NUMEST=IA(N0 + NG-NEGL - 1)
      NREC2=NG - NEGL
      CALL READMS (NN,EE,NUMEST,NREC2)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
  116 CALL ELEMNT
  120 CONTINUE
C
C     3. FORM EFFECTIVE MASS MATRIX FOR CENTRAL DIFFERENCE METHOD ONLY
C
  121 IF (IOPE.NE.3) GO TO 128
C
      WRITE (11) (DD(I),I=1,NEQ)
      WRITE (11) (BB(I),I=1,NEQ)
      DO 129 I=1,NEQ
      DD(I)=A0*DD(I) + A1*BB(I)
      IF (DD(I).GT.0.) GO TO 129
      WRITE (6,3000) I,DD(I)
      STOP
  129 CONTINUE
      REWIND 7
      WRITE (7) (DD(I),I=1,NEQ)
      RETURN
C
  128 WRITE (11) (DD(I),I=1,NEQU)
      IF (ISTAT.EQ.0 .AND. IDGRAV.EQ.1) GO TO 122
      WRITE (11) (BB(I),I=1,NEQU)
      GO TO 200
  122 IMASS=0
      RETURN
C
C     2.2 CONSISTENT  MASS  MATRIX
C
  110 NEQL=1
      NEQR=0
      MLA=0
C
      DO 130 L=1,NBLOCK
      NCOLB=NCOLBV(L)
      NEQR=NEQR + NCOLB
      IF (ISUB.GT.0) GO TO 134
      REWIND 1
      GO TO 136
  134 DO 135 I=1,NEG
  135 BACKSPACE 1
  136 NN=1
      DO 140 I=1,ISTOH
  140 AA(I)=0.
C
      IF (NEG.EQ.0) GO TO 151
      DO 150 NG=1,NEG
      IF (ISUB.GT.0) GO TO 141
      IF (NG.GT.NEGL) NN=2
  141 IF (NN.EQ.1) READ(NN) NUMEST,(EE(I),I=1,NUMEST)
      IF (NN.EQ.1) GO TO 145
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NUMEST=IA(N0 + NG-NEGL - 1)
      NREC2=NG - NEGL
      CALL READMS (NN,EE,NUMEST,NREC2)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  145 CALL ELEMNT
  150 CONTINUE
C
  151 IF (IMASSN.EQ.0) GO TO 154
      DO 152 I=1,NCOLB
      NI=NEQL + I -1
      II=MAXA(NI) - MLA
  152 AA(II)=AA(II) + DD(NI)
  154 WRITE (11) AA
      NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL) - 1
  130 CONTINUE
C
      WRITE (11) (BB(I),I=1,NEQU)
C
C
C     3. FORM EFFECTIVE LINEAR STIFFNESS MATRIX AND STORE ON TAPE 7
C        FOR IMPLICIT TIME INTEGRATION ONLY
C
C
  200 IF (NSTE.EQ.0 .OR. IMODES.GT.0) RETURN
      NT=7
      IF (ISUB.GT.0) NT=12
      NEQL=0
      MLA=0
      REWIND 4
      REWIND NT
      IF (NSUBST.EQ.0) REWIND 11
C
      IF (IMASS.EQ.2) GO TO 260
C
      DO 210 L=1,NBLOCK
      IF (NEGL.EQ.0 .AND. NSUBST.EQ.0) GO TO 212
      READ (4) AA
      GO TO 216
  212 DO 214 I=1,ISTOH
  214 AA(I)=0.
  216 NCOLB=NCOLBV(L)
      DO 220 K=1,NCOLB
      II=MAXA(NEQL+K) - MLA
      AA(II)=AA(II) + A0*DD(NEQL+K) + A1*BB(NEQL+K)
  220 CONTINUE
      WRITE (NT) AA
      NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL+1) - 1
  210 CONTINUE
      RETURN
C
  260 IF (NSUBST.EQ.0) GO TO 262
      NN=NBLOCK + 1
      DO 261 I=1,NN
  261 BACKSPACE 11
  262 DO 270 L=1,NBLOCK
      IF (NEGL.EQ.0 .AND. NSUBST.EQ.0) GO TO 263
      READ (4) AA
      GO TO 266
  263 DO 264 I=1,ISTOH
  264 AA(I)=0.
  266 READ (11) CC
      DO 280 K=1,ISTOH
  280 AA(K)=AA(K) + A0*CC(K)
      IF (IDAMPN.EQ.0) GO TO 290
      NCOLB=NCOLBV(L)
      DO 284 K=1,NCOLB
      II=MAXA(NEQL+K) - MLA
  284 AA(II)=AA(II) + A1*BB(NEQL+K)
      NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL+1) - 1
  290 WRITE (NT) AA
  270 CONTINUE
      IF (NSUBST.EQ.0) GO TO 299
      IF (ISUB.GT.0) READ (11)
      IF (ISUB.GT.0) GO TO 299
      DO 298 I=1,NBLOCK
  298 BACKSPACE 11
  299 RETURN
C
C
C     D U R I N G   T I M E   I N T E G R A T I O N
C
C
C     EFFECTIVE LINEAR STIFFNESS MATRIX IS READ AND ELEMENT ROUTINES
C     ARE CALLED TO UPDATE THE MATRIX AND THE EFFECTIVE LOAD VECTOR
C     FOR NONLINEARITIES
C
  300 IF (KLIN.EQ.0 .AND. IOPE.NE.3) GO TO 385
C
C     FOR CENTRAL DIFFERENCE METHOD ONLY, FORM EFFECTIVE LOAD VECTOR IN
C     LINEAR ANALYSIS AND NONLINEAR ANALYSIS
C
  297 IF (IOPE.NE.3 .OR. NEGL.EQ.0) GO TO 303
      NEQL=1
      NEQR=NEQ
      REWIND 1
      DO 301 NG=1,NEGL
      READ (1) NUMEST,(EE(I),I=1,NUMEST)
      CALL ELEMNT
  301 CONTINUE
      IF (NEGNL.EQ.0) RETURN
C
C     READ NODAL POINT TEMPERATURES
C
  303 IF (ITEMPR.EQ.0) GO TO 302
      NUMP1=NUMNP + 1
      READ (56) (TEMPV2(I),I=1,NUMP1)
      CALL TCHECK (TEMPV2,TIME)
C
C       1. CASE OF NO NEW STIFFNESS MATRIX TO BE FORMED
C
  302 NEQL=1
      NEQR=NEQ
      IF (IREF.EQ.0) GO TO 310
      DO 306 NG=1,NEGNL
      NUMEST=IA(N0 + NG - 1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  304 NREC2=NG
      CALL READMS (2,EE,NUMEST,NREC2)
      CALL ELEMNT
      NREC2=NG
      CALL WRITMS (2,EE,NUMEST,NREC2,-1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  306 CONTINUE
      GO TO 350
C
C       2. CASE OF NEW STIFFNESS MATRIX TO BE FORMED
C
  310 NEQR=0
      MLA=0
      NTAPE=4
      IF (ISTAT.EQ.1) NTAPE=7
      REWIND NTAPE
      REWIND 12
C
      SMAX=0.
      SMIN=1.E50
      DO 340 L=1,NBLOCK
      NEQR=NEQR + NCOLBV(L)
      IF (ISTAT.EQ.1) GO TO 314
      IF (NEGL.GT.0 .OR. NSUBST.GT.0) GO TO 314
      DO 312 I=1,ISTOH
  312 AA(I)=0.
      GO TO 316
  314 READ (NTAPE) AA
  316 DO 320 NG=1,NEGNL
      NUMEST=IA(N0 + NG - 1)
      IF (NBLOCK.EQ.1 .OR. NUMEG.EQ.1) GO TO 318
      IF (MODEX.NE.2 .AND. KSTEP.EQ.1) GO TO 318
      IF (IGRBLC(L,NG).EQ.-1) GO TO 320
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  318 NREC2=NG
      CALL READMS (2,EE,NUMEST,NREC2)
      CALL ELEMNT
      NREC2=NG
      CALL WRITMS (2,EE,NUMEST,NREC2,-1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      IF (NBLOCK.EQ.1 .OR. NUMEG.EQ.1) GO TO 320
      IF (MODEX.EQ.2 .OR. KSTEP.GT.1) GO TO 320
      IGRBLC(L,NG)=IELCPL
  320 CONTINUE
C
      DO 330 I=NEQL,NEQR
      II=MAXA(I) - MLA
      IF (AA(II).GT.SMAX) SMAX=AA(II)
      IF (AA(II).LT.SMIN) SMIN=AA(II)
  330 CONTINUE
C
      WRITE (12) AA
      NEQL=NEQL + NCOLBV(L)
      MLA=MAXA(NEQL) - 1
  340 CONTINUE
C
C     CALCULATE NORM OF INCREMENTAL LOAD
C
  350 CONTINUE
C
C     AT PRESCRIBED DISPLACEMENT DOF MODIFY LOAD VECTOR APPROPRIATELY
C
  385 IF (NPDIS.EQ.0) RETURN
      NP=1
      NN=NOD(NP)
      PIVOT=10.**20
      DO 400 I=1,NEQ
      IF (I - NN) 400,390,400
  390 DUM=PRDIS(NP)
      IF (KLIN.GT.0) DUM=PRDIS(NP) - DD(I)
      BB(I)=SMAX*PIVOT*DUM
      IF (NP.EQ.NPDIS) RETURN
      NP=NP + 1
      NN=NOD(NP)
  400 CONTINUE
C
      RETURN
C
C
C     F R E Q U E N C Y   A N A L Y S I S
C
C
C     LINEAR STIFFNESS MATRIX IS READ FROM TAPE
C     AND IS UPDATED FOR NONLINEARITIES
C
  600 IF (MODEX.EQ.0 .OR. NEGNL.EQ.0) GO TO 650
C
C     READ NODAL POINT TEMPERATURES
C
      IF (ITEMPR.EQ.0) GO TO 602
      NUMP1=NUMNP + 1
      READ (56) (TEMPV2(I),I=1,NUMP1)
      CALL TCHECK (TEMPV2,TIME)
      BACKSPACE 56
C
  602 IND=4
      NEQL=1
      NEQR=0
      MLA=0
      REWIND 4
      REWIND 12
C
      DO 610 L=1,NBLOCK
      NEQR=NEQR + NCOLBV(L)
      IF (NEGL.GT.0 .OR. NSUBST.GT.0) GO TO 620
      DO 630 I=1,ISTOH
  630 AA(I)=0.
      GO TO 632
  620 READ (4) AA
C
  632 DO 640 NG=1,NEGNL
C
C     * * * * *    R A N D O M   A C C E S S   * * * *
C
      NUMEST=IA(N0 + NG - 1)
      NREC2=NG
      CALL READMS (2,EE,NUMEST,NREC2)
C
C     * * * * *    R A N D O M   A C C E S S   * * * *
C
      CALL ELEMNT
  640 CONTINUE
C
      WRITE (12) AA
      NEQL=NEQL + NCOLBV(L)
      MLA=MAXA(NEQL) - 1
  610 CONTINUE
C
C     CALCULATE FREQUENCIES AND MODE SHAPES
C
C *CDC*  650 CALL OVERLAY (5HADINA,20B,0B,6HRECALL)
  650 CALL FREQS
C
 3000 FORMAT (3X,10H***STOP***       /,
     1        13X,38HZERO EFFECTIVE MASS INPUT FOR D.O.F. =  ,I5   /,
     2        13X,22HEFFECTIVE MASS VALUE =  ,E14.6    /)
      RETURN
C
C
      END
C *CDC* *DECK,LOADMS
C *UNI* )FOR,IS  N.LOADMS, R.LOADMS
      SUBROUTINE LOADMS
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE EFFECTIVE LOADS FOR MASTER STRUCTURE          .
C .        AND, IF APPLICABLE, FOR SUBSTRUCTURES                      .
C .                                                                   .
C .        APPLIED LOADS ARE BROUGHT INTO CORE FROM TAPE AND          .
C .        LOADEF IS CALLED TO CALCULATE EFFECTIVE LOADS.  FOR        .
C .        SUBSTRUCTURES, THE LOAD VECTOR IS ALSO REDUCED AND         .
C .        ADDED TO THE MASTER STRUCTURE LOAD VECTOR                  .
C .        ALSO, THE NONLINEAR STIFFNESS EFFECT AND, IF APPLICABLE,   .
C .        THE MASS AND DAMPING EFFECTS ARE ADDED TO THE EFFECTIVE    .
C .        LOAD VECTOR.                                               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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 /RANDI/ N0A,N1D,IELCPL
      COMMON /SRANDI/ N09A,N09B
      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 /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /TEMP/ ISPEC
      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 /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 /SUBSTF/ NREC16
      COMMON /LOA/ NLOAD,NPR2,NPR3,NODE3,IDGRAV,NPDIS,NTEMP
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /DPR/ ITWO
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /DISCON/ NDISCE,NIDM
      COMMON A(1)
      INTEGER IA(1)
      REAL A
      DIMENSION DIRCOS(9)
      EQUIVALENCE (A(1),IA(1))
C
C      E X T E R N A L L Y   A P P L I E D   L O A D S
C                    (M A S T E R)
C
      NN=N3 + NEQ*ITWO - 1
      READ (3) (A(I),I=N3,NN)
      IF (IMODES.GT.0) RETURN
      IF (NSUBST.EQ.0) REWIND 11
      CALL LOADEF (A(N1),A(N1A),A(N2),A(N1),A(N7),A(N8),A(N3),A(N6),
     1             A(N4),A(N9),A(N04),A(N05),NBLOCK,ISTOH,NEQ)
      REWIND 11
C
C     SUBSTRUCTURE LOADS
C
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 300
      ISUB=1
      NEQT=NEQ + NDISCE
      M2=N2 + NEQT*ITWO
      M3=N3 + NEQT*ITWO
      M7=N7 + NEQT*ITWO
      M8=N8 + NEQT*ITWO
      M9=N9 + NEQ*ITWO
      NREC16=0
      NREC17=NSTE  + KSTEP
      REWIND NSTAPE
      DO 200 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
      M1A=N1S + NEQS + 1
      M1B=M1A + NBLOCS
      NN=M1B + NBLOCS - 1
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,
     1                   (IDOFS(I),I=1,6),NDOFS,(IA(I),I=N1S,NN)
      IF (IMASS.EQ.2) GO TO 120
      NN=M9 + NEQS*ITWO - 1
      READ (11) (A(I),I=M9,NN)
  120 DO 150 NTM=1,NTUSE
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      CALL READMS (17,A(M3),NEQS,NREC17)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      CALL LOADEF (A(N1S),A(M1A),A(M2),A(N1S),A(M7),A(M8),A(M3),A(N6),
     1             A(N4),A(M9),A(M9),A(M9),NBLOCS,ISTOHS,NEQS)
C
C
C     REDUCE LOAD VECTOR AND ADD TO MASTER LOAD VECTOR
C
C
C
C      TAKE REDUCED STIFFNESS MATRIX INTO CORE, IF ONE BLOCK CASE
C           (AND NOT ALREADY THERE)
      IF (NBLOCS.GT.1) GO TO 140
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      KK=NREC16 + 1
      CALL READMS(16,A(N4),ISTOHS,KK)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
  140 CONTINUE
      CALL COLSOL (A(N1S),A(M1A),A(N1S),A(N4),A(N4),A(M3),A(M3),A(N1S),
     1             NEQS,NBLOCS,ISTOHS,12,16,2)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      CALL WRITMS (17,A(M3),NEQC,NREC17,-1)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S,
     2             (DIRCOS(I),I=1,9),ND,(IA(N6+I-1),I=1,ND)
      NN=NEQC*ITWO + M3
      CALL ADDMA (A(N3),A(NN),A(N6),ND)
      M2=M2 + NEQS*ITWO
      M7=M7 + NEQS*ITWO
      M8=M8 + NEQS*ITWO
      NREC17=NREC17 + NSTE
      IF (IDAMPN.EQ.1 .AND. NTM.LT.NTUSE) BACKSPACE 11
      IF (IMASS.NE.2 .OR. NTM.EQ.NTUSE) GO TO 150
      DO 145 II=1,NBLOCS
  145 BACKSPACE 11
  150 CONTINUE
      IF (IDAMPN.EQ.0) READ (11)
      NREC16=NREC16 + NBLOCS + 1
  200 CONTINUE
      ISUB=0
  300 IF (IOPE.EQ.3) GO TO 400
      IF (ISPEC.EQ.1) GO TO 310
      REWIND 22
      NN=N3 + NEQ*ITWO - 1
      WRITE (22) (A(I),I=N3,NN)
C
C     ADD MASS EFFECT IF NEGL AND NSUBST EQ 0
C     AND ISPEC EQUALS 0
C
      IF (KLIN.EQ.0) GO TO 320
      IF (NEGL.GT.0 .OR. NSUBST.GT.0) GO TO 315
      IF(ISTAT.EQ.0) GO TO 400
      CALL SHTADV (A(N3),A(N2),A(N9),A0,NEQ,3)
      IF (IDAMPN.EQ.0) GO TO 320
      NN=N4 + NEQ*ITWO -1
      READ (11) (A(I),I=N4,NN)
      BACKSPACE 11
      CALL SHTADV (A(N3),A(N2),A(N4),A1,NEQ,3)
      GO TO 320
C
C     STIFFNESS EFFECT (IN NONLINEAR ANALYSIS)
C
  310 IF (KLIN.EQ.0) GO TO 320
      IF (NEGL.EQ.0 .AND. NSUBST.EQ.0) GO TO 320
  315 NF=4
      IF (ISTAT.GT.0 .AND. ISPEC.EQ.0) NF=7
      REWIND NF
      CALL MULT (A(N3),A(N4),A(N2),IA(N1),IA(N1A),NEQ,ISTOH,NBLOCK,NF)
  320 IF (ISTAT.EQ.0) GO TO 400
C
C     REINSTATE L*D*L(T) IN HIGH SPEED STORAGE IF NECESSARY
C
      IF (NBLOCK.GT.1 .OR. KLIN.GT.0) GO TO 400
      IF (NSUBST.GT.0 .AND. ISTAT.GT.0) GO TO 350
      IF (IDAMPN.EQ.0 .AND. IMASS.EQ.1) GO TO 400
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
  350 NN=ISTOH
      NREC10=1
      CALL READMS(10,A(N4),NN,NREC10)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
  400 RETURN
C
      END
C *CDC* *DECK LOADEF
C *UNI* )FOR,IS  N.LOADEF, R.LOADEF
      SUBROUTINE LOADEF (MAXA,NCOLBV,DISP,DISPM,VEL,ACC,R,WV,AA,XM,
     1                  NOD,PRDIS,NBLOCK,ISTOH,NEQ)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE EFFECTIVE LOADS (EXCLUDING NONLINEAR          .
C .        CONTRIBUTIONS)                                             .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /RANDI/ N0A,N1D,IELCPL
      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 /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 /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 /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /DPR/ ITWO
      DIMENSION DISP(1),VEL(1),ACC(1),R(1),WV(1),AA(1),XM(1)
      DIMENSION DISPM(1),NOD(1),PRDIS(1)
      INTEGER MAXA(1),NCOLBV(1)
      INTEGER IA(1)
      COMMON A(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
      IF (IMODES.GT.0) RETURN
      IF (ISUB.GT.0) GO TO 60
C
      IF (IOPE.EQ.3) GO TO 105
      IF (NPDIS.GT.0) READ (13) (PRDIS(I),I=1,NPDIS)
C
   60 IF (ISTAT.EQ.0) GO TO 142
C
C
C     I M P L I C I T   I N T E G R A T I O N   M E T H O D
C
C     M A S S   E F F E C T
C
C
      IF (ISPEC.GT.0) GO TO 110
C
C     LINEAR ANALYSIS OR DYNAMIC SUBSTRUCTURING
C
      DO 100 I=1,NEQ
  100 WV(I)=-A0*DISP(I) - A2*VEL(I) - A3*ACC(I)
      IF (IMASS.EQ.2) GO TO 130
      GO TO 115
C
C     SPECIAL CASE  ( NOW ALL NONLINEAR ANALYSIS
C                     EXCEPT DYNAMIC SUBSTRUCTURING)
C
  110 DO 120 I=1,NEQ
  120 WV(I)=-A2*VEL(I) - A3*ACC(I)
      IF (IMASS.EQ.2) GO TO 130
C
  115 DO 170 I=1,NEQ
  170 R(I)=R(I) - XM(I)*WV(I)
      GO TO 150
  130 CALL MULT (R,AA,WV,MAXA,NCOLBV,NEQ,ISTOH,NBLOCK,11)
C
C
C     N O D A L   D A M P I N G   E F F E C T
C
C
  150 IF (IDAMPN.EQ.0) GO TO 142
      IF (ISPEC.GT.0) GO TO 125
C
C     LINEAR ANALYSIS OR DYNAMIC SUBSTRUCTURING
C
      DO 132 I=1,NEQ
  132 WV(I)=-A1*DISP(I) - A4*VEL(I) - A5*ACC(I)
      GO TO 135
C
C     SPECIAL CASE  ( NOW ALL NONLINEAR ANALYSIS
C                     EXCEPT DYNAMIC SUBSTRUCTURING)
C
  125 DO 138 I=1,NEQ
  138 WV(I)=-A4*VEL(I) - A5*ACC(I)
C
  135 READ(11) (AA(I),I=1,NEQ)
      DO 139 I=1,NEQ
  139 R(I)=R(I) - AA(I)*WV(I)
  142 RETURN
C
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
C
  105 IF (NPDIS.EQ.0) GO TO 104
      IF (KSTEP.GT.1) GO TO 104
      READ (13) (PRDIS(I),I=1,NPDIS)
      NP=1
      NN=NOD(NP)
      DO 30 I=1,NEQ
      IF (I - NN) 30,25,30
   25 DISP(I)=PRDIS(NP)
      IF (NPDIS.EQ.NP) GO TO 104
      NP=NP + 1
      NN=NOD(NP)
   30 CONTINUE
C
  104 IF (IDAMPN.NE.0) GO TO 108
      DO 106 I=1,NEQ
  106 R(I)=R(I) + AA(I)*(DISP(I) + DISP(I) - DISPM(I))
      RETURN
C
  108 READ (11) (AA(I),I=1,NEQ)
      DO 107 I=1,NEQ
  107 R(I)=R(I) + A2*AA(I)*(DISP(I) - DISPM(I))
      READ (7) (AA(I),I=1,NEQ)
      DO 109 I=1,NEQ
  109 R(I)=R(I) + AA(I)*DISPM(I)
      RETURN
C
      END
C *CDC* *DECK COLSOL
C *UNI* )FOR,IS  N.COLSOL, R.COLSOL
      SUBROUTINE COLSOL (MAXA,NCOLBV,ICOPL,A,B,D,V,NOD,
     1                   NEQ,NBLOCK,ISTORL,NSTIF,NRED,KKK)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .        TO SOLVE FINITE ELEMENT STATIC EQUILIBRIUM EQUATIONS OUT-OF.
C .        CORE, USING COMPACTED STORAGE AND COLUMN REDUCTION SCHEME  .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      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 /SUBSTF/ NREC16
C
      DIMENSION A(ISTORL),B(ISTORL),D(NEQ),V(1)
      INTEGER ICOPL(1),NCOLBV(1),MAXA(1),NOD(1)
C
      KHBB=0
      IF (ISUB.EQ.0) NEQC=NEQ + 1
      IF (KKK - 2) 10,610,750
   10 REWIND NSTIF
      PIVOT=10.**20
      DMAX=0.
      DMIN=1.E50
      NP=1
      IF (NPDIS.GT.0) NN=NOD(NP)
C
C - - FACTORIZE STIFFNESS MATRIX  ( LOOP OVER ALL BLOCKS ) - -
C
      DO 600 NJ=1,NBLOCK
C
      READ (NSTIF) A
      NCOLB=NCOLBV(NJ)
      MM=MAXA(KHBB+1) - 1
      IF (ISUB.GT.0) GO TO 80
      IF (NPDIS.EQ.0) GO TO 80
C
      IF (NN.LE.KHBB) GO TO 80
      IF (NN.GT.KHBB+NCOLB) GO TO 80
      DO 40 N=1,NCOLB
      KK=KHBB + N
      IF (NN - KK) 40,20,40
   20 KL=MAXA(NN) - MM
      A(KL)=SMAX*PIVOT
      IF (NP.EQ.NPDIS) GO TO 80
      NP=NP + 1
      NN=NOD(NP)
   40 CONTINUE
C
   80 IF (NJ.EQ.ICOPL(NJ)) GO TO 300
C
      IK=ICOPL(NJ) - 1
      IM=0
      IF (IK) 300,140,100
  100 DO 120 K=1,IK
  120 IM=IM + NCOLBV(K)
  140 KHB=KHBB - IM
      IK=IK + 1
      NJ1=NJ - 1
C
C     REDUCE BLOCK BY THE PRECEEDING COUPLING BLOCKS
C
      DO 160 NK=IK,NJ1
C
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC10=NK
      IF (ISUB.GT.0) NREC10=NREC10 + NREC16
      CALL READMS (NRED,B,ISTORL,NREC10)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      KHB=KHB - NCOLBV(NK)
      MC=MAXA(IM+1) - 1
C
      DO 200 N=1,NCOLB
      KN=MAXA(KHBB+N) - MM
      KL=KN + 1
      KU=MAXA(KHBB+N+1) - 1 - MM
      KH=KU - KL - N + 1
      KC=KH - KHB
      KS=N + KHBB
      IF (KS.LE.NEQC) GO TO 205
      KDIF=KU - KL
      KK=KS - NEQC - 1
      IF (KDIF.LT.KK) GO TO 200
  205 IF (KC.LE.0) GO TO 200
      IC=0
      KCL=NCOLBV(NK) - KC + 1
      IF (KCL.GT.0) GO TO 210
      IC=1 - KCL
      KCL=1
  210 KCR=NCOLBV(NK)
      KLT=KU - IC
C
      DO 220 K=KCL,KCR
      IC=IC + 1
      KLT=KLT - 1
      KI=MAXA(K+IM) - MC
      ND=MAXA(K+IM+1) - KI - MC - 1
      IF(ND) 220,220,230
  230 KK=MIN0(IC,ND)
      C=0.
      JJ=1
      IF (K+IM.LE.NEQC) GO TO 235
      JJ=K + IM - NEQC
      IF (KK.LT.JJ) GO TO 220
  235 DO 240 L=JJ,KK
  240 C=C + B(KI+L)*A(KLT+L)
      A(KLT)=A(KLT) - C
  220 CONTINUE
  200 CONTINUE
C
      IM=IM + NCOLBV(NK)
C
  160 CONTINUE
C
C     REDUCE BLOCK BY ITSELF
C
  300 DO 400 N=1,NCOLB
      KN=MAXA(KHBB+N) - MM
      KL=KN + 1
      KU=MAXA(KHBB+N+1) - 1 - MM
      KDIF=KU - KL
      KH=MIN0(KDIF,N-1)
      KS=N + KHBB
      IF (KDIF.LT.KS - NEQC - 1) GO TO 400
      IF (KH) 420,440,460
  460 K=N - KH
      KLT=KL + KH
      IC=0
      IF ((N-1).LT.KDIF) IC=KDIF - N + 1
C
      DO 480 J=1,KH
      IC=IC + 1
      KLT=KLT - 1
      KI=MAXA(KHBB+K) - MM
      ND=MAXA(KHBB+K+1) - KI - MM - 1
      IF (ND) 480,480,500
  500 KK=MIN0(IC,ND)
      C=0.
      JJ=1
      IF (K+KHBB.LE.NEQC) GO TO 510
      JJ=K + KHBB - NEQC
      IF (KK.LT.JJ) GO TO 480
  510 DO 520 L=JJ,KK
  520 C=C + A(KI+L)*A(KLT+L)
      A(KLT)=A(KLT) - C
  480 K=K + 1
C
  440 K=KS
      IF (KS.LE.NEQC) GO TO 450
      K=NEQC + 1
      JJ=KS - NEQC - 1
      KL=KL + JJ
      KH=KU - KL
      IF (KH) 400,450,450
  450 E=0.
      DO 540 KK=KL,KU
      K=K - 1
      C=A(KK)/D(K)
      E=E + C*A(KK)
  540 A(KK)=C
      A(KN)=A(KN) - E
C
  420 IF (KS - NEQC) 550,550,400
  550 D(KS)=A(KN)
      IF (D(KS)) 560,555,400
  555 IF (IDTHF.EQ.0) GO TO 560
      D(KS)=PIVOT
      GO TO 400
  560 WRITE (6,2000) KS,D(KS)
      WRITE (6,2020)
      STOP
C
  400 CONTINUE
C
      KHBB=KHBB + NCOLB
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC10=NJ
      IF (ISUB.GT.0) NREC10=NREC10 + NREC16
      CALL WRITMS (NRED,A,ISTORL,NREC10,-1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  600 CONTINUE
      IF (ISUB.GT.0) RETURN
C
C     CALCULATE EXTREMAL VALUES OF D VECTOR
C
      NP=1
      NN=0
      IF (NPDIS.GT.0) NN=NOD(NP)
      DO 605 I=1,NEQ
      IF (I - NN) 604,602,604
  602 NP=NP + 1
      IF (NP.LE.NPDIS) NN=NOD(NP)
      GO TO 605
  604 IF (D(I).GT.DMAX) DMAX=D(I)
      IF (D(I).EQ.0.E+00)  GO TO 605
      IF (D(I).LT.DMIN) DMIN=D(I)
  605 CONTINUE
      IF (KLIN.GT.0) GO TO 606
      RETURN
C
C - - SOLUTION OF EQUATIONS ( LOOP OVER ALL BLOCKS ) - -
C
C     REDUCE THE LOAD VECTOR
C
  606 KHBB=0
  610 DO 700 NJ=1,NBLOCK
      IF (NBLOCK.NE.1) GO TO 715
      IF (ISUB.GT.0) GO TO 710
      IF (KLIN.EQ.0 .OR. KKK.EQ.1) GO TO 710
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  715 NREC10=NJ
      IF (ISUB.GT.0) NREC10=NREC10 + NREC16
      CALL READMS (NRED,A,ISTORL,NREC10)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
  710 NCOLB=NCOLBV(NJ)
      MM=MAXA(KHBB+1) - 1
      DO 720 N=1,NCOLB
      KL=MAXA(N+KHBB) - MM + 1
      KU=MAXA(N+KHBB+1) - MM - 1
      KS=N + KHBB
      K=KS
      IF (KS.LE.NEQC) GO TO 725
      K=NEQC + 1
      KL=KL + KS - NEQC - 1
  725 IF (KU - KL) 720,730,730
  730 C=0.
      DO 740 KK=KL,KU
      K=K - 1
  740 C=C + A(KK)*V(K)
      V(KS)=V(KS) - C
  720 CONTINUE
      KHBB=KHBB + NCOLB
  700 CONTINUE
C
      NN=NEQ
      IF (ISUB.EQ.0) GO TO 770
      RETURN
C
C     BACKSUBSTITUTE
C
  750 NCOLB=NCOLBV(1)
      KHBB=NEQ
      NN=NEQC
C
  770 DO 790 N=1,NN
  790 V(N)=V(N)/D(N)
      NBL=NBLOCK
      DO 800 NJ=1,NBLOCK
      IF (NBLOCK.EQ.1) GO TO 820
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NJB1=NBLOCK - NJ + 1
      IF (ISUB.GT.0) NJB1=NJB1 + NREC16
      CALL READMS (NRED,A,ISTORL,NJB1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NCOLB=NCOLBV(NBL)
  820 KHBB=KHBB - NCOLB
      MM=MAXA(KHBB+1) - 1
      N=NCOLB
      DO 860 L=1,NCOLB
      KL=MAXA(N+KHBB) - MM + 1
      KU=MAXA(N+KHBB+1) - MM - 1
      KS=N + KHBB
      K=KS
      IF (KS.LE.NEQC) GO TO 850
      K=NEQC + 1
      KL=KL + KS - NEQC - 1
  850 IF (KU - KL) 861,890,890
  890 DO 900 KK=KL,KU
      K=K - 1
  900 V(K)=V(K) - A(KK)*V(KS)
  861 N=N-1
  860 CONTINUE
      NBL=NBL - 1
  800 CONTINUE
C
      RETURN
C
 2000 FORMAT (/
     1 55H *** STOP - STIFFNESS MATRIX NOT POSITIVE DEFINITE ***  //
     2 32H NONPOSITIVE PIVOT FOR EQUATION  ,I5                     /
     3 10H PIVOT =  ,E21.12                                       //
     4 55H *** IN SMALL DISPLACEMENT LINEAR ELASTIC ANALYSIS ***   /
     5 55H     CHECK THE FOLLOWING --                              //
     6 55H (A) BOUNDARY CONDITIONS -                               /
     7 55H          THE B.C. MUST NOT ADMIT A RIGID BODY           /
     8 55H          DISPLACEMENT OR ROTATION OF THE TOTAL          /
     8 55H          STRUCTURE.                                     //
     A 55H (B) DELETION OF DEGREES-OF-FREEDOM -                    /
     B 55H          ALL D.O.F. AT NODAL POINTS WITHOUT             /
     C 55H          STIFFNESS CONTRIBUTIONS FROM ELEMENTS          /
     D 55H          MUST HAVE BEEN DELETED.                        )
 2020 FORMAT (//
     1 55H (C) ELEMENT GEOMETRY AND CONNECTIVITY -                 /
     2 55H          ALL ELEMENTS MUST HAVE BEEN INPUT WITH         /
     2 55H          PROPER NODAL NUMBERS, AS DESCRIBED IN          /
     3 55H          THE USERS MANUAL.                              //
     4 55H (D) ELEMENT INTEGRATION ORDERS -                        /
     5 55H          THE ORDERS OF NUMERICAL INTEGRATIONS FOR       /
     5 55H          EVALUATION OF ELEMENT MATRICES MUST BE         /
     5 55H          SUFFICIENTLY HIGH.                             //
     4 55H (E) MATERIAL DATA -                                     /
     5 55H          ALL MATERIAL DATA MUST BE PHYSICALLY           /
     6 55H          REASONABLE (E.G. YOUNG*S MODULUS MUST          /
     6 55H          BE GREATER THAN ZERO).                         //
     7 55H *** IN MATERIALLY NONLINEAR AND/OR LARGE DISPLACEMENT
     8 55H ANALYSIS ***                                            //
     9 55H     IF THE MODEL HAS BEEN INPUT CORRECTLY (WITH ALL     /
     A 55H     THE ABOVE CONSIDERATIONS TAKEN INTO ACCOUNT), THEN  /
     B 55H     THE COLLAPSE LOAD OF THE MODEL HAS BEEN REACHED.    ///)
C
      END
C *CDC* *DECK SBLOCK
C *UNI* )FOR,IS  N.SBLOCK,  R.SBLOCK
      SUBROUTINE SBLOCK (MAXA,NCOLBV,ICOPL,ISTORL,NBLOCK,NEQ,NWK,ISTOH)
C
      INTEGER MAXA(1),NCOLBV(1),ICOPL(1)
C
C     CHECK FOR ONE BLOCK CASE
C
      IF (NBLOCK.GT.1) GO TO 5
      IF (NWK.GT.ISTORL) GO TO 5
      NBLOCK=1
      NCOLBV(1)=NEQ
      ICOPL(1)=1
      ISTOH=NWK
      RETURN
C
C     CHECK WHETHER ISTORL/2 IS AT LEAST AS LARGE AS ANY ONE COLUMN
C
    5 ISTOH=ISTORL/2
      ISTORL=2*ISTOH
      DO 10 I=1,NEQ
      ICL=MAXA(I+1) - MAXA(I)
      IF (ISTOH.GE.ICL) GO TO 10
      WRITE (6,2000) I
      STOP
   10 CONTINUE
C
C     ESTABLISH THE NUMBER OF COLUMNS PER BLOCK
C
      NBLOCK=0
      NN=0
      IB=0
C
      DO 100 I=2,NEQ
  140 II=ISTOH - MAXA(I+1) + 1 + NN
      IF (II) 120,100,100
  120 NN=MAXA(I) - 1
      NBLOCK=NBLOCK + 1
      NCOLBV(NBLOCK)=I - 1 - IB
      IB=I - 1
      GO TO 140
  100 CONTINUE
      NBLOCK=NBLOCK + 1
      NCOLBV(NBLOCK)=NEQ - IB
C
C     ESTABLISH COUPLING OF BLOCKS
C
      DO 50 I=1,NBLOCK
   50 ICOPL(I)=I
      IF (NBLOCK.EQ.1) RETURN
      NN=NCOLBV(1)
      DO 200 N=2,NBLOCK
      ICLM=0
      NCOLB=NCOLBV(N)
      DO 110 I=1,NCOLB
      ICL=MAXA(NN+I+1) - MAXA(NN+I) - I - 1
      IF (ICL.GT.ICLM) ICLM=ICL
  110 CONTINUE
      J=N-1
  150 IF (ICLM.LE.0) GO TO 180
      ICOPL(N)=J
      ICLM=ICLM - NCOLBV(J)
      J=J-1
      GO TO 150
  180 NN=NN + NCOLBV(N)
  200 CONTINUE
C
 2000 FORMAT (1H1,49H***ERROR HIGH SPEED STORAGE IS TOO SMALL TO FIT   ,
     1            6HCOLUMN,2H (,I5,2H) ,10HINTO CORE   )
      RETURN
      END
C
C
C
C *CDC* *DECK EQUIT
C *UNI* )FOR,IS  N.EQUIT,  R.EQUIT
      SUBROUTINE EQUIT (AA,DISPI,DINCOR,RE,DISP,VEL,ACC,MAXA,WV,XM,EE,
     1                  CC,DK,NCOLBV,ICOPL,ISTOH)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO ITERATE FOR DYNAMIC EQUILIBRIUM                         .
C .                                                                   .
C .   METHOD = 1  MODIFIED NEWTON ITERATION                           .
C .      IATKEN = 0  NO ACCELERATION                                  .
C .      IATKEN = 1  AITKEN ACCELERATION                              .
C .                                                                   .
C .   METHOD = 2  BFGS MATRIX UPDATING                                .
C .                                                                   .
C .        AA   = EFFECTIVE STIFFNESS MATRIX AND WORKING STORAGE      .
C .        RE   = OUT OF BALANCE LOADS                                .
C .        DISP = DISPLACEMENT AT PREVIOUS TIME STEP                  .
C .        DISPI= DISPLACEMENT INCREMENT AT CURRENT TIME STEP         .
C .        DINCOR DISPLACEMENT INCREMENT CORRECTION                   .
C .        VEL  = VELOCITY AT PREVIOUS TIME STEP                      .
C .        ACC  = ACCELERATION AT PREVIOUS TIME STEP                  .
C .        MAXA = ADDRESSES OF DIAGONAL ELEMENTS IN EFFECTIVE         .
C .               STIFFNESS MATRIX                                    .
C .        WV   = WORKING VECTOR                                      .
C .        DK   = ELEMENTS OF D IN L*D*L(T) FACTORIZATION OF          .
C .               EFFECTIVE STIFFNESS MATRIX                          .
C .        CC   = WORKING STORAGE IN OUT-OF-CORE SOLUTION             .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
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           ,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 /MSUPER/ IMODES,NMODES,IMDAMP
      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 /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      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 /RANDI/ N0A,N1D,IELCPL
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /ENERGY/ PE,PEOLD,PEINIT
      COMMON /ITMTHD/ MAXUP,NUMUPD,NTBFGS,NATKN
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /DISCON/ NDISCE,NIDM
      COMMON A(1)
      INTEGER IA(1)
      DIMENSION AA(1),DISPI(1),RE(1),DISP(1),VEL(1),ACC(1),MAXA(1),WV(1)
     1         ,XM(1),CC(1),DK(1),EE(1),DINCOR(1)
      INTEGER NCOLBV(1),ICOPL(1)
      REAL EE,A
      EQUIVALENCE (A(1),IA(1))
C
      NATKN=18
      NTBFGS=NATKN
      MAXUP=20
      NUMUPD=0
C
      ICOUNT=3
      ICONVG=0
      ITE=0
      IACC=1
      NEQL=1
      NEQR=NEQ
      NEQT=NEQ + NDISCE
C
      IF (IMODES.GT.0) GO TO 500
C
C     CALCULATE INITIAL POTENTIAL ENERGY FOR DIVERGENCE CHECK AND
C     CONVERGENCE CRITERIA
C
      PEINIT=PRDINN(RE,DISPI,NEQ)
      PEOLD=PEINIT
C
C     IF AITKEN ACCELERATION IS TO BE USED (IATKEN # 0)
C     DISP IS USED AS A WORKING ARRAY AND IS STORED ON TAPE NATKN AS :
C        1) DISPLACEMENT AT PREVIOUS TIME STEP
C        2) DISPLACEMENT INCREMENT FOR AITKEN ACCELERATION
C
      IF (IATKEN.EQ.0) GO TO 499
      REWIND NATKN
      WRITE (NATKN) (DISP(I),I=1,NEQT)
      WRITE (NATKN) (DISPI(I),I=1,NEQ)
      DNORM=PRDINN(DISPI,DISPI,NEQ)
      DNORM=DSQRT(DNORM)
      DNMTOL=0.01*DNORM
C
  499 IF (METHOD.LT.2) GO TO 500
C
C     AT PRESCRIBED DOF"S ASSIGN DISPI AND ZERO DINCOR
C
      IF (NPDIS.EQ.0) GO TO 20
      NP=1
      NN=IA(N04)
      DO 15 I=1,NEQT
      IF (I-NN) 5,10,5
    5 DINCOR(I)=DISPI(I)
      DISPI(I)=0.0
      GO TO 15
   10 DINCOR(I)=0.0
      NP=NP + 1
      IF (NP.GT.NPDIS) GO TO 15
      NN=IA(N04 + NP - 1)
   15 CONTINUE
      GO TO 30
C
   20 DO 25 I=1,NEQT
      DINCOR(I)=DISPI(I)
   25 DISPI(I)=0.0
   30 REWIND NTBFGS
      WRITE (NTBFGS) (RE(I),I=1,NEQ)
      REWIND NTBFGS
C
  500 ITE=ITE + 1
      STEP=1.0
      IF (METHOD.LT.2) STEP=0.0
      CALL UNBLD (STEP,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,MAXA,
     1            WV,XM,EE,NCOLBV,ISTOH)
C
      IF (IMODES.GT.0) GO TO 237
      IF (ITE.EQ.1 .AND. PEINIT.LT.1.0D-10*RNORM) PEINIT=1.0D-10*RNORM
C
C     CHECK WHETHER LINE SEARCH IS NECESSARY
C
      IF (METHOD.LT.2) GO TO 200
      PE=PRDINN(DINCOR,RE,NEQ)
      IF (DABS(PE).LE.(STOL*DABS(PEOLD))) GO TO 110
C
      CALL LISRCH (PE,PEOLD,STEP,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,MAXA,
     1             WV,XM,EE,NCOLBV,ISTOH)
C
C     C A L C U L A T E   I N C R E M E N T   I N
C                                     D I S P L A C E M E N T S
C
  110 DO 120 I=1,NEQT
  120 DISPI(I)=DISPI(I) + STEP*DINCOR(I)
C
  200 IF (PEOLD.GT.10000.0*PEINIT) GO TO 210
      IF (ITE  .LT. (ITEMAX/2+1)) GO TO 230
C
C     CHECK THAT POTENTIAL ENERGY OF SYSTEM IS DECREASING
C
      IF (PEOLD.LE.PEINIT) GO TO 230
  210 IEQREF=1
      ICOUNT=2
      BACKSPACE 3
      RETURN
C
  230 DO 235 I=1,NEQ
  235 WV(I)=RE(I)
C
C     CALCULATE NORM OF INCREMENTAL LOAD
C
      RENORM=PRDINN(RE,RE,NEQ)
      RENORM=DSQRT(RENORM)
C
      IF (METHOD.LT.2) GO TO 250
      DINORM=PRDINN(DINCOR,DINCOR,NEQ)
      DINORM=DSQRT(DINORM)*STEP
      GO TO 250
C
C *CDC*  237 CALL OVERLAY (5HADINA,21B,0B,6HRECALL)
  237 CALL MODSUP
      GO TO 290
C
  250 CALL NEWDIR (PE,PEOLD,STEP,DINCOR,AA,DISPI,RE,DINORM,DISP,VEL,ACC,
     1             MAXA,WV,XM,EE,CC,DK,NCOLBV,ICOPL,ISTOH)
C
C
C     CALCULATE NEW POTENTIAL ENERGY
C
      IF (METHOD.EQ.1) PEOLD=PRDINN(RE,WV,NEQ)
      IF (METHOD.EQ.2) PEOLD=PRDINN(DINCOR,RE,NEQ)
C
C
C     C H E C K   F O R   C O N V E R G E N C E
C
C
      IF (RNORM.EQ.0.0) GO TO 290
      IF (RENORM.GT.RTOL*RNORM) GO TO 256
  290 IF (PEOLD.GT.ETOL*PEINIT) GO TO 256
      ICONVG=1
  256 IF (IATKEN.EQ.0 .OR. ICONVG.EQ.1) GO TO 298
C
C     CHECK WHICH ACCELERATION SCHEME SHOULD BE USED
C
      IF (IATKEN.GT.1) GO TO 281
C
C     USE AITKEN ACCELERATION ON EACH DEGREE OF FREEDOM
C
      IACC=IACC + 1
      IF (IACC.EQ.2) GO TO 265
      WRITE (NATKN) (RE(I),I=1,NEQ)
      GO TO 298
C
C     APPLY ACCELERATION FACTOR
C
  265 READ (NATKN) (DISP(I),I=1,NEQ)
      IACC=0
      DO 280 I=1,NEQ
      DENOM=DISP(I) - RE(I)
      IF (DABS(DENOM).LT.DNMTOL) GO TO 275
      ACFAC=RE(I)/DENOM
      GO TO 276
  275 ACFAC=0.0
  276 RE(I)=RE(I)*(1.0 + ACFAC)
  280 CONTINUE
      GO TO 298
C
C     OVERRELAXATION
C
  281 CONTINUE
C
C     ADD INCREMENT TO TOTAL DISPLACEMENT INCREMENT
C
  298 IF (NDISCE.EQ.0) GO TO 299
C
      IF (METHOD.EQ.1)
     1   CALL CONDIS (A(N01),A(N02),A(N03),RE,VEL,ACC,NIDM,0)
      IF (METHOD.EQ.2)
     1   CALL CONDIS (A(N01),A(N02),A(N03),DINCOR,VEL,ACC,NIDM,0)
C
  299 IF (METHOD.EQ.2) GO TO 310
      DO 300 I=1,NEQT
  300 DISPI(I)=DISPI(I) + RE(I)
C
  310 IF (ICONVG.EQ.1) GO TO 400
C
  370 IF (ITE.LT.ITEMAX) GO TO 500
      IF (RNORM.GT.0.0) GO TO 381
      WRITE (6,2031) RENORM,PEINIT,PEOLD
      GO TO 382
  381 RTNORM=RTOL*RNORM
      WRITE (6,2030) RTNORM,RENORM,PEINIT,PEOLD
  382 CONTINUE
      WRITE(6,2010) KSTEP,ITE
      WRITE(6,2020)
      ITE=ITE + 1
      RETURN
C
  400 ICOUNT=2
      IF (RNORM.GT.0.0) GO TO 385
      WRITE (6,2031) RENORM,PEINIT,PEOLD
      GO TO 386
  385 RTNORM=RTOL*RNORM
      WRITE (6,2030) RTNORM,RENORM,PEINIT,PEOLD
  386 CONTINUE
      IF (METHOD.EQ.1) RETURN
      DO 410 I=1,NEQT
  410 DISPI(I)=DISPI(I) + DINCOR(I)
      RETURN
C
 2010 FORMAT (//// 37H EQUILIBRIUM ITERATION IN TIME STEP = ,I5 //
     1             37H NUMBER OF ITERATIONS               = ,I5  /)
 2020 FORMAT (////45H ITERATION LIMIT REACHED WITH NO CONVERGENCE  /5X,
     1            24H S T O P   OF SOLUTION   )
 2030 FORMAT (  1H ,35HNORMS IN LAST EQUILIBRIUM ITERATION  //
     1 50H MAXIMUM ALLOWED UNBALANCED LOAD NORM            =,E15.6/
     2 50H NORM OF UNBALANCED LOAD                         =,E15.6//
     3 50H INCREMENTAL ENERGY NORM IN THIS STEP            =,E15.6/
     4 50H NORM OF UNBALANCED INCREMENTAL ENERGY           =,E15.6 )
 2031 FORMAT (1H ,35HNORMS IN LAST EQUILIBRIUM ITERATION   //
     1 50H MAXIMUM ALLOWED UNBALANCED LOAD NORM            =,
     2 3X, 17H(** NOT USED **)                                    /
     3 50H NORM OF UNBALANCED LOAD                         =,E15.6//
     4 50H INCREMENTAL ENERGY NORM IN THIS STEP            =,E15.6/
     5 50H NORM OF UNBALANCED INCREMENTAL ENERGY           =,E15.6 )
C
      END
C *CDC* *DECK UNBLD
C *UNI* )FOR,IS N.UNBLD,R.UNBLD
      SUBROUTINE UNBLD (STEP,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,MAXA,WV,
     1                  XM,EE,NCOLBV,ISTOH)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .      P R O G R A M                                                .
C .                                                                   .
C .         TO COMPUTE THE UNBALANCED LOAD IN THE CONFIGURATION       .
C .         DISP + DISPI + STEP*DINCOR                                .
C .         (STEP = 0.0 FOR METHOD = 1)                               .
C .                                                                   .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      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 /MSUPER/ IMODES,NMODES,IMDAMP
      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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      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 /SHV1/ N010
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /ENERGY/ PE,PEOLD,PEINIT
      COMMON /ITMTHD/ MAXUP,NUMUPD,NTBFGS,NATKN
      COMMON A(1)
C
      INTEGER IA(1)
      DIMENSION AA(1),DISPI(1),DISP(1),RE(1),VEL(1),ACC(1),DINCOR(1),
     1          WV(1),XM(1)
      INTEGER NCOLBV(1),MAXA(1)
      REAL EE(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
C
C     C A L C U L A T E   C U R R E N T    R H S   L O A D S
C
C
      NEQT=NEQ + NDISCE
C
C     FOR BFGS METHOD, TEMPORARILY ADD STEP*DINCOR TO DISPI
C
      IF (METHOD.EQ.1) GO TO 15
      DO 10 I=1,NEQT
   10 DISPI(I)=DISPI(I) + STEP*DINCOR(I)
C
   15 IF (MAXMSS.EQ.0) GO TO 20
      KNOR=2
      CALL NORMAL (A(N08),A(N09),A(N010),A(N3),A(N5),NDOF,KNOR)
C
   20 IF (ISPEC.EQ.0) GO TO 24
      BACKSPACE 3
      READ (3) (RE(I),I=1,NEQ)
      GO TO 25
   24 REWIND 22
      READ (22) (RE(I),I=1,NEQ)
C
   25 IF (IMODES.GT.0) GO TO 110
C
C     READ DISPLACEMENTS OFF TAPE NATKN
C
      IF (IATKEN.EQ.0) GO TO 26
      REWIND NATKN
      READ (NATKN) (DISP(I),I=1,NEQT)
C
C     IN DIVERGENCE PROCEDURE, SUBTRACT OFF RESIDUAL LOAD (DINCOR)
C
   26 IF (ISDVG.LT.2) GO TO 50
      IF (NPDIS.EQ.0) GO TO 28
      NP=1
      NN=IA(N04)
      DO 31 I=1,NEQ
      IF (I-NN) 32,33,32
   32 RE(I)=RE(I) - DINCOR(I)
      GO TO 31
   33 NP=NP + 1
      IF (NP.GT.NPDIS) GO TO 31
      NN=IA(N04 + NP - 1)
   31 CONTINUE
      GO TO 50
C
   28 DO 27 I=1,NEQ
   27 RE(I)=RE(I) - DINCOR(I)
C
C
C     C A L C U L A T E   L I N E A R   B A L A N C E D   L O A D S
C
C
   50 IF (NEGL.EQ.0 .AND. NSUBST.EQ.0) GO TO 100
C
C     STIFFNESS EFFECT
C
      REWIND 4
C
      DO 29 I=1,NEQT
   29 WV(I)=DISP(I) + DISPI(I)
C
      NF=4
      IF (ISPEC.EQ.0 .AND. IMASS.GT.0) NF=7
      REWIND NF
      CALL MULT (RE,AA,WV,MAXA,NCOLBV,NEQ,ISTOH,NBLOCK,NF)
C
      IF (ISTAT.EQ.0) GO TO 110
      IF (ISPEC.NE.1) GO TO 110
      GO TO 105
C
C     ADD MASS AND DAMPING EFFECT IF
C     NEGL AND NSUBST EQ 0 AND ISPEC EQ 0
C
  100 IF (ISTAT.EQ.0) GO TO 110
      IF (ISPEC.EQ.1) GO TO 105
      DO 101 I=1,NEQT
  101 WV(I)=DISP(I) + DISPI(I)
      DO 102 I=1,NEQ
  102 RE(I)=RE(I) - WV(I)*XM(I)*A0
      IF (IDAMPN.EQ.0) GO TO 110
      REWIND 11
      READ (11) (AA(I),I=1,NEQ)
      REWIND 11
      DO 104 I=1,NEQ
  104 RE(I)=RE(I) - WV(I)*AA(I)*A1
      GO TO 110
  105 REWIND 11
C
C     MASS EFFECT
C
      DO 30 I=1,NEQ
      WV(I)=A0*DISPI(I) - A2*VEL(I) - A3*ACC(I)
   30 CONTINUE
      IF (IMASS.EQ.2) GO TO 60
      DO 40 I=1,NEQ
      RE(I)=RE(I) - WV(I)*XM(I)
   40 CONTINUE
      GO TO 70
   60 REWIND 11
      CALL MULT (RE,AA,WV,MAXA,NCOLBV,NEQ,ISTOH,NBLOCK,11)
C
C     DAMPING EFFECT
C
   70 IF (IDAMPN.EQ.0) GO TO 110
      READ (11) (AA(I),I=1,NEQ)
      DO 90 I=1,NEQ
      RE(I)=RE(I) - AA(I)*(A1*DISPI(I) - A4*VEL(I) - A5*ACC(I))
   90 CONTINUE
C
  110 DO 120 I=1,NEQT
  120 WV(I)=DISP(I) + DISPI(I)
C
C
C     A D D   N O N L I N E A R   C O N T R I B U T I O N S
C
C
      DO 200 N=1,NEGNL
      NUMEST=IA(N0 + N - 1)
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC2=N
      CALL READMS (2,EE,NUMEST,NREC2)
C
      CALL ELEMNT
C
C     FOR CONTACT SURFACES, STORE INFORMATION DURING EQUILIBRIUM
C     ITERATION
C
      NREC2=N
      IF (NPAR(1).EQ.13) CALL WRITMS (2,EE,NUMEST,NREC2,-1)
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
  200 CONTINUE
C
C     CALCULATE CONTRIBUTION TO INITIAL POTENTIAL ENERGY FROM
C     PRESCRIBED DISPLACEMENTS
C
      IF (IMODES.GT.0) GO TO 500
      IF (NPDIS.EQ.0) GO TO 240
      IF (ITE.GT.1) GO TO 240
      IF (METHOD.EQ.2 .AND. STEP.NE.1.0) GO TO 240
      DO 230 I=1,NPDIS
      II=IA(N04 + I - 1)
      RENORM=RENORM + RE(II)*RE(II)
  230 PEINIT=PEINIT - RE(II)*DISPI(II)
      PEOLD=PEINIT
C
C     FOR BFGS METHOD, TAKE OUT STEP*DINCOR FROM DISPI
C
  240 IF (METHOD.EQ.1) GO TO 500
      DO 250 I=1,NEQT
  250 DISPI(I)=DISPI(I) - STEP*DINCOR(I)
C
  500 RETURN
      END
C *CDC* *DECK LISRCH
C *UNI* )FOR,IS N.LISRCH,R.LISRCH
      SUBROUTINE LISRCH (Y,YOLD,STEP,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,
     1                   MAXA,WV,XM,EE,NCOLBV,ISTOH)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .      P R O G R A M                                                .
C .         TO DO A LINE SEARCH IN THE DIRECTION OF DINCOR.           .
C .         RESULT IS A STEPLENGTH ,STEP, WHICH APPROXIMATES THE TRUE .
C .         STEPLENGTH WITH A RELATIVE ACCURACY OF STOL.              .
C .         THE METHOD USED IS A MODIFICATION OF THE SO CALLED        .
C .         ILLINOIS-ALGORITHM, WHICH IS ITSELF A MODIFICATION        .
C .         OF REGULA FALSI. THE ILLINOIS-ALGORITHM COMBINES THE      .
C .         SAFETY OF REGULA FALSI WITH THE FASTER CONVERGENCE        .
C .         OF THE SECANT METHOD. HERE WE ACCELERATE THE              .
C .         CONVERGENCE EVEN MORE BY USING RATIONAL INTERPOLATION     .
C .         WHEN POSSIBLE.                                            .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      DIMENSION AA(1),DISPI(1),DISP(1),RE(1),VEL(1),ACC(1),DINCOR(1),
     1          WV(1),XM(1)
      INTEGER NCOLBV(1),MAXA(1)
      REAL EE(1)
C
      LINMAX = 10
      SAMAX=10.
      YA = Y
      YB = YOLD
      SB = 0.0
      SA = 1.0
C
C     FIND BRACKET ON ZERO
C
   10 CONTINUE
      IF ((YA*YB).LE.0.0) GO TO 20
      SB=SA
      SA=SA + SA
      YB=YA
      CALL UNBLD (SA,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,MAXA,WV,XM,EE,
     1            NCOLBV,ISTOH)
      YA=PRDINN(DINCOR,RE,NEQ)
      STEP=SA
      Y=YA
      IF (SA.GT.SAMAX) GO TO 15
      GO TO 10
C
C
C     ILLINOIS-ALGORITHM WITH RATIONAL INTERPOLATION TO FIND
C        ZERO WITH RELATIVE ACCURACY OF STOL.
C
C
   20 DO 22 J=1,LINMAX
      STEP=SA - YA*(SA - SB)/(YA - YB)
      CALL UNBLD (STEP,DINCOR,AA,DISPI,RE,DISP,VEL,ACC,MAXA,WV,XM,EE,
     1            NCOLBV,ISTOH)
      Y=PRDINN(DINCOR,RE,NEQ)
C
C        COMPUTE BETA FOR RATIONAL INTERPOLATION
C
      BETA=0.5
      IF (DABS(STEP - SA) .LT. 1.0D-20) GO TO 25
      BETA=(Y - YA)*(SA - SB)/((YA - YB)*(STEP - SA))
      IF (BETA.LT.1.0D-2 .OR. BETA.GT.0.5D0) BETA=0.5D0
   25 YB=BETA*YB
      IF ((Y*YA).GT.0.0) GO TO 30
      SB=SA
      YB=YA
   30 SA=STEP
      YA=Y
      IF (DABS(Y).LT.(STOL*DABS(YOLD)) .AND.
     1    DABS(SB - SA).LT.(STOL*DMAX1(SA,SB))) GO TO 15
   22 CONTINUE
   15 CONTINUE
      RETURN
      END
C *CDC* *DECK NEWDIR
C *UNI* )FOR,IS N.NEWDIR,R.NEWDIR
      SUBROUTINE NEWDIR (Y,YOLD,STEP,DINCOR,AA,DISPI,RE,DINORM,DISP,VEL,
     1                   ACC,MAXA,WV,XM,EE,CC,DK,NCOLBV,ICOPL,ISTOH)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .      P R O G R A M                                                .
C .                                                                   .
C .         TO FIND A NEW SEARCH DIRECTION.                           .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /EQIT/ METHOD,IATKEN,NLSTPD,NLSTEP,ITEDIV,ISDVG
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /ITMTHD/ MAXUP,NUMUPD,NTBFGS,NATKN
      COMMON A(1)
      INTEGER IA(1)
      DIMENSION AA(1),DISPI(1),DISP(1),RE(1),VEL(1),ACC(1),DINCOR(1),
     1          WV(1),XM(1),CC(1),DK(1)
      INTEGER NCOLBV(1),ICOPL(1),MAXA(1)
      REAL EE(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
      CONDMX=1.0E05
      IF (METHOD.GE.2) GO TO 5
      CALL COLSOL (MAXA,NCOLBV,ICOPL,AA,CC,DK,RE,A(N04),NEQ,NBLOCK,
     1             ISTOH,12,10,2)
      RETURN
    5 NUMUPD = MOD (NUMUPD,MAXUP)
C
C     WE ALREADY HAVE
C           Y = )DINCOR,RESID# AND YOLD = )DINCOR,OLDRESID#
C
C     WE COMPUTE
C
C           DELGAM = )DELTA,GAMMA# = STEP*)DINCOR,OLDRESID-RESID#
C     AND
C           DELH1D = )DELTA,H(-1)DELTA# = STEP**2 * )DINCOR,OLDRESID#
C
      DELGAM = STEP*(YOLD-Y)
      IF (DABS(YOLD-Y).LT.1.D-12) YOLD=Y
      DELH1D = STEP*STEP*YOLD
C
C     CHECK CONDITIONS FOR UPDATING
C
      IUP=0
      IF (DELGAM.GT.0.0 .AND. DELH1D.GT.0.0) IUP=1
      IF (IUP.EQ.1) GO TO 13
      DO 12 I=1,NEQ
      DINCOR(I)=RE(I)
   12 CONTINUE
      IF (NUMUPD.EQ.0) REWIND NTBFGS
      WRITE (NTBFGS) (RE(I),I=1,NEQ)
      BACKSPACE NTBFGS
      GO TO 15
C
C     READ THE OLD RESIDUAL
C
   13 READ (NTBFGS) (WV(I),I=1,NEQ)
      BACKSPACE NTBFGS
      IF (NUMUPD.EQ.0) REWIND NTBFGS
      FACT1=-DSQRT(DELGAM/DELH1D)*STEP - 1.0
      FACT2 = STEP/DELGAM
C
C     WV = V = (DSQRT(DELGAM/DELH1D)*STEP-1)*OLDRESID + RESID
C
C     RESID = U = STEP/DELGAM * DINCOR
C
      IF (NPDIS.EQ.0) GO TO 21
      NP=1
      NN=IA(N04)
      DO 22 I=1,NEQ
      IF (I-NN) 23,24,23
   23 AUX=RE(I)
      WV(I)=AUX + FACT1*WV(I)
      RE(I)=FACT2*DINCOR(I)
      DINCOR(I)=AUX
      GO TO 22
   24 DINCOR(I)=RE(I)
      WV(I)=0.0
      RE(I)=0.0
      NP=NP + 1
      IF (NP.GT.NPDIS) GO TO 22
      NN=IA(N04 + NP - 1)
   22 CONTINUE
      GO TO 26
C
   21 DO 20 I=1,NEQ
      AUX=RE(I)
      WV(I)=AUX + FACT1*WV(I)
      RE(I)=FACT2*DINCOR(I)
      DINCOR(I)=AUX
   20 CONTINUE
C
C     CHECK ESTIMATE ON INCREASE OF CONDITION NUMBER
C     OF UPDATED MATRIX   (ESTCON)
C
C     WE HAVE : X1 = )V,V#
C               X2 = )U,U#
C               X3 = 4*()U,V# + 1) = 4*()RESID,WV# + 1)
C
   26 X1=PRDINN(WV,WV,NEQ)
      X2 = DINORM*DINORM/(DELGAM*DELGAM)
      X3=4.*FACT2*(FACT1*YOLD + Y) + 4.0
      IF (X3.EQ.0.0) IUP=0
      IF (IUP.EQ.0) GO TO 16
      X4=DABS(X1*X2 + X3)
      ESTCON=((DSQRT(X1)*DSQRT(X2) + DSQRT(X4))**2.0)/DABS(X3)
      IF (ESTCON.GE.CONDMX) IUP=0
      IF (IUP.EQ.0) GO TO 16
C
C     SAVE UPDATING VECTORS
C
      WRITE (NTBFGS) (WV(I),I=1,NEQ)
      WRITE (NTBFGS) (RE(I),I=1,NEQ)
C
C     SAVE NEW RESIDUAL LOAD (IN DINCOR) FOR NEXT ITERATION
C
   16 WRITE (NTBFGS) (DINCOR(I),I=1,NEQ)
      BACKSPACE NTBFGS
      IF (IUP.EQ.0) GO TO 15
      BACKSPACE NTBFGS
      BACKSPACE NTBFGS
C
C     RIGHT HALF OF UPDATING
C
      FACTOR = FACT2 * Y
      DO 25 I=1,NEQ
      DINCOR(I)=DINCOR(I) + FACTOR*WV(I)
   25 CONTINUE
   15 CONTINUE
      IF (NUMUPD.EQ.0) GO TO 37
      DO 30 J=1,NUMUPD
      BACKSPACE NTBFGS
      READ (NTBFGS) (RE(I),I=1,NEQ)
      FACTOR=PRDINN(DINCOR,RE,NEQ)
      BACKSPACE NTBFGS
      BACKSPACE NTBFGS
      READ (NTBFGS) (WV(I),I=1,NEQ)
      DO 35 I=1,NEQ
      DINCOR(I)=DINCOR(I) + FACTOR*WV(I)
   35 CONTINUE
      BACKSPACE NTBFGS
   30 CONTINUE
C
C     BACKSUBSTITUTION
C
   37 CALL COLSOL (MAXA,NCOLBV,ICOPL,AA,CC,DK,DINCOR,A(N04),NEQ,NBLOCK,
     1             ISTOH,12,10,2)
C
C     LEFT HALF OF UPDATING
C
      IF (IUP.EQ.1) NUMUPD=NUMUPD + 1
      REWIND NTBFGS
      IF (NUMUPD.EQ.0) GO TO 50
      DO 40 J=1,NUMUPD
      READ (NTBFGS) (WV(I),I=1,NEQ)
      FACTOR=PRDINN(DINCOR,WV,NEQ)
      READ (NTBFGS) (RE(I),I=1,NEQ)
      DO 45 I=1,NEQ
   45 DINCOR(I)=DINCOR(I) + FACTOR*RE(I)
   40 CONTINUE
C
C     READ RESID FOR COMPUTATION OF YOLD IN EQUIT
C
   50 READ (NTBFGS) (RE(I),I=1,NEQ)
      BACKSPACE NTBFGS
      RETURN
      END
C *CDC* *DECK DIVERG
C *UNI* )FOR,IS  N.DIVERG,  R.DIVERG
      SUBROUTINE DIVERG (DISP,R,RESID,AA,RE,WV,VEL,ACC,XM,EE,B,DK,
     1                   NCOLBV,ICOPL,MAXA,IGRBLC,TEMPV2)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   P R O G R A M                                                   .
C .       TO CALCULATE ELASTIC STIFFNESS MATRIX AND MODIFY LOAD STEP  .
C .       SIZE IN CASE OF DIVERGENCE IN EQUILIBRIUM ITERATION         .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      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 /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /DPR/ ITWO
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /ULJ/ IULJ
      COMMON /DVGREF/ INDMNO
      COMMON /MIDSYS/ NMIDSS,MIDIND,MAXMSS
      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 /DISCON/ NDISCE,NIDM
C
      DIMENSION DISP(1),R(1),AA(1),RE(1),WV(1),VEL(1),ACC(1),XM(1),
     1          EE(1),B(1),DK(1),NCOLBV(1),ICOPL(1),MAXA(1),IGRBLC(1),
     2          TEMPV2(1),RESID(1)
C
      COMMON A(1)
      INTEGER IA(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
C
      IF (NLSTPD.EQ.0) GO TO 400
      NN=N1 - 1
      REWIND 9
      IF (MAXMSS.GT.0) READ(9) (A(I),I=N09,NN)
      ITESUM=ITE
      ITEDIV=ITE
      ITDVMX=NLSTPD*ITEMAX
      ISDVG=2
      NLSTEP=0
      FACTOR=0.0
      DELFAC=0.0
      IF (ISTAT.EQ.1) DELFAC=1.0
      IREF=0
      IREFD=0
      WRITE (6,2500) NLSTPD
C
C     DETERMINE CORRECTIVE LOAD FACTOR
C
   10 DLFACO=DELFAC
      DELFAC=DELFAC*DELFAC
      IF (DLFACO.LT.0.25 .AND. DLFACO.GT.0.0625) DELFAC=0.0625
      IF (DELFAC.EQ.0.0) DELFAC=0.5
      IF (DELFAC.LT.0.0625) GO TO 500
C
      KTR=1
C
      IF (NPDIS.GT.0) BACKSPACE 13
      CALL LOADEF (MAXA,NCOLBV,DISP,MAXA,VEL,ACC,R,WV,AA,XM,A(N04),
     1             A(N05),NBLOCK,ISTOH)
C
C     CALCULATE LOAD INCREMENT AND ELASTIC STIFFNESS (IF REQUESTED)
C     IN ASSEM
C
   20 CONTINUE
      BACKSPACE 56
      CALL ASSEM (MAXA,AA,B,DISP,R,RE,EE,NCOLBV,TEMPV2,IGRBLC,
     1            EE,A(N04),A(N05),ISTOH,NBLOCK)
C
C     SCALE LOAD INCREMENT BY SCALING FACTOR AND SAVE
C
      DO 30 I=1,NEQ
      RESID(I)=R(I)*(1.0 - (DELFAC/(1.0 - FACTOR)))
      R(I)=R(I)*DELFAC/(1.0 - FACTOR)
   30 RE(I)=R(I)
C
C     SOLVE FOR DISPLACEMENT INCREMENTS AND ITERATE
C
      IF (IREF.EQ.1) KTR=2
      CALL COLSOL (MAXA,NCOLBV,ICOPL,AA,B,DK,R,A(N04),NEQ,NBLOCK,ISTOH,
     1             12,10,KTR)
C
      IEQREF=0
C
      IF (NDISCE.GT.0)
     1  CALL CONDIS(A(N01),A(N02),A(N03),R,VEL,ACC,NIDM,0)
C
      CALL EQUIT (AA,R,RESID,RE,DISP,VEL,ACC,MAXA,WV,XM,EE,B,DK,NCOLBV,
     1            ICOPL,ISTOH)
C
C     IF CONVERGENCE IS NOT ATTAINED, DECREMENT LOAD STEP FURTHER
C
      ITESUM=ITESUM + ITE
      ITEDIV=ITEDIV + ITE
      IF (ITEDIV.GT.ITDVMX) GO TO 200
      IF (ITE.GT.ITEMAX) GO TO 500
      IF (IEQREF.EQ.0) GO TO 50
      IF (ISTAT.EQ.1) GO TO 500
      GO TO 10
C
C     DETERMINE NEXT LOAD STEP SIZE
C
   50 NLSTEP=NLSTEP + 1
      FACTOR=FACTOR + DELFAC
      IF (IREFD.EQ.0) WRITE (6,2550) NLSTEP,FACTOR,ITESUM
      IF (IREFD.EQ.1) WRITE (6,2551) NLSTEP,FACTOR,ITESUM
      ITESUM=0
      IREFD=1
      IF (FACTOR.EQ.1.0) GO TO 100
      IF (NLSTEP.EQ.NLSTPD) GO TO 500
      DELFAC=0.5
      IF (ITE.GT.4) DELFAC=0.25
      IF (ITE.GT.12) DELFAC=0.0625
      IF ((FACTOR + DELFAC).GT.1.0) DELFAC=1.0 - FACTOR
C
C     UPDATE DISPLACEMENTS IN NEWDAV
C
      CALL NEWDAV (AA,R,RE,MAXA,DISP,R,VEL,ACC,A(N04),A(N05),NEQ,1)
C
      IF (NDISCE.GT.0)
     1  CALL CONDIS(A(N01),A(N02),A(N03),DISP,VEL,ACC,NIDM,ISTAT)

C
C     SHIFT DISPLACEMENT INCREMENTS IN ULJ FORMULATION
C
      IF (IULJ.EQ.0) GO TO 70
      DO 60 I=1,NEQ
   60 RE(I)=R(I)
C
C     RE-READ THE EXTERNAL LOAD VECTOR IN LOADEF
C
   70 BACKSPACE 3
      IF (NPDIS.GT.0) BACKSPACE 13
      CALL LOADEF (MAXA,NCOLBV,DISP,MAXA,VEL,ACC,R,WV,AA,XM,A(N04),
     1             A(N05),NBLOCK,ISTOH)
C
C     RECALCULATE STIFFNESS, IF REQUIRED, AND TAKE NEXT LOAD INCREMENT
C
      KTR=1
      IREF=0
      IF (INDMNO.EQ.1) IREF=1
      IF (IREF.EQ.0) IREFD=0
      GO TO 20
C
C     RETURN IF LOAD STEP HAS BEEN SUCCESSFULLY CALCULATED
C
  100 ISDVG=0
      WRITE (6,2600) NLSTEP,ITEDIV
      RETURN
C
  200 WRITE (6,2000) NLSTEP,FACTOR
      WRITE (6,2200) ITDVMX
      ISDVG=1
      RETURN
C
  400 WRITE (6,2100) ITE
      ISDVG=1
      RETURN
C
  500 WRITE (6,2000) NLSTEP,FACTOR
      ISDVG=1
      RETURN
C
 2000 FORMAT (44H CONVERGENCE NOT ATTAINED FOR THIS LOAD STEP/
     1        10X,38H NUMBER OF SMALLER LOAD STEPS TAKEN = ,I5/
     2        10X,34H FRACTION OF TOTAL LOAD REACHED = ,E14.6)
 2100 FORMAT (////67H OUT OF BALANCE LOADS LARGER THAN INCREMENTAL LOADS
     1 AFTER ITERATION,I5)
 2200 FORMAT (//36H MAXIMUM NUMBER OF TOTAL ITERATIONS,,I5,9H EXCEEDED)
 2500 FORMAT (//50H ATTEMPT TO ITERATE WITH THIS LOAD STEP FAILED TO ,
     1        8HCONVERGE//
     2        44H LOAD STEP WILL BE DIVIDED INTO A MAXIMUM OF,I5,
     3        41H SMALLER LOAD STEPS TO ATTAIN CONVERGENCE//
     4        3X,9HLOAD STEP,7X,11HFRACTION OF,10X,9HSTIFFNESS,
     5        9X,9HNUMBER OF/4X,6HNUMBER,10X,10HTOTAL LOAD,9X,
     6        12HREFORMATION&,7X,10HITERATIONS/)
 2550 FORMAT (6X,I2,7X,E14.6,13X,3HYES,13X,I5)
 2551 FORMAT (6X,I2,7X,E14.6,13X,3H NO,13X,I5)
 2600 FORMAT (/40H CONVERGENCE ATTAINED FOR THIS LOAD STEP/
     1        10X,38H NUMBER OF SMALLER LOAD STEPS TAKEN = ,I5/
     2        10X,38H TOTAL NUMBER OF ITERATIONS REQUIRED = ,I5)
C
      END
C *CDC* *DECK NDAVMS
C *UNI* )FOR,IS N.NDAVMS, R.NDAVMS
      SUBROUTINE NDAVMS
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE NEW DISPLACEMENTS, VELOCITIES, AND            .
C .        ACCELERATIONS AT TIME=T + DELTA(T) FOR MASTER              .
C .        STRUCTURES AND, IF APPLICABLE, FOR SUBSTRUCTURES.          .
C .                                                                   .
C .        IF DYNAMIC SUBSTRUCTURING IS USED, STORAGE VARIABLES ARE   .
C .        SET, NEEDED INFORMATION IS READ INTO CORE, AND INTERNAL    .
C .        SUBSTRUCTURE DISPLACEMENTS ( OR DISPLACEMENT INCREMENTS)   .
C .        ARE CALCULATED BEFORE CALLING NEWDAV TO CALCULATE          .
C .        VELOCITIES AND ACCELERATIONS                               .
C .        NEWDAV IS CALLED FOR THE MASTER DEGREES OF FREEDOM         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      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 /SUBSTF/ NREC16
      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 /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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,N1S
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /SRANDI/ N09A,N09B
      COMMON /DIMN/ N3A,N4A,N4B,N4C
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /LOA/ NLOAD,NPR2,NPR3,NODE3,IDGRAV,NPDIS,NTEMP
      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 /TIMFN/ TEND,NTFN,NPTM
      COMMON /DPR/ ITWO
      COMMON A(1)
      INTEGER IA(1)
      REAL A
      EQUIVALENCE (A(1),IA(1))
C
C     SUBSTRUCTURE CALCULATIONS
C
      IF (NSUBST.EQ.0 .OR. ISTAT.EQ.0) GO TO 300
      IF (KLIN.EQ.0) GO TO 20
C
C     CALCULATE MASTER DISPLACEMENTS
C
      FACTOR=0.
      CALL SHTADV (A(N3),A(N3),A(N2),FACTOR,NEQ,2)
   20 ISUB=1
      NEQT=NEQ + NDISCE
C
C     CHANGE STORAGE INDICES
C
      M2=N2 + NEQT*ITWO
      M3=N3 + NEQT*ITWO
      M7=N7 + NEQT*ITWO
      M8=N8 + NEQT*ITWO
      M9=N9 + NEQ*ITWO
      NREC16=0
      NREC17=NSTE  + KSTEP
      REWIND NSTAPE
      IF (KSTEP.EQ.1) REWIND 23
      DO 200 NSUB=1,NSUBST
      NN=N07 + 8*(NSUB - 1)
      NEQS=IA(NN)
      NWKS=IA(NN + 1)
      MAXES=IA(NN + 2)
      NBCEL=IA(NN + 3)
      NBLOCS=IA(NN + 4)
      ISTOHS=IA(NN + 5)
      NEQC=IA(NN + 6)
      M1A=N1S + NEQS + 1
      M1B=M1A + NBLOCS
      NN=M1B + NBLOCS - 1
      READ (NSTAPE) NTUSE,NEGLS,NUMNPS,NODCON,NODRET,
     1                   (IDOFS(I),I=1,6),NDOFS,(IA(I),I=N1S,NN)
C
C     READ L AND D FACTORS OF STIFFNESS MATRIX INTO CORE
C
      IF (NBLOCS.NE.1) GO TO 50
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      KK=NREC16 + 1
      CALL READMS (16,A(N4),ISTOHS,KK)
   50 KK=NREC16 + NBLOCS + 1
      CALL READMS (16,A(N4C),NEQC,KK)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
C
C     RESPONSE OF REPEATED SUBSTRUCTURES
C
      DO 100 NTU=1,NTUSE
C
C     EXTRACT DISP AT RETAINED DOF FROM MASTER DOF DISPLACEMENTS
C
      KRSIZE=NEQS
      CALL SUBSKR (A(M3),A(M3),A(N3),A(N6),A(N1S),A(M1A),
     1             ISTOHS,NBLOCS,NREC16,NREC17,KRSIZE,NEQ)
C
C     CALCULATE INTERNAL DISPLACEMENTS
C
      CALL COLSOL (A(N1S),A(M1A),A(M1B),A(N4),A(N4),A(N4C),A(M3),
     1             A(N04),NEQS,NBLOCS,ISTOHS,12,16,3)
      FACTOR=0.
      IF (KLIN.GT.0) CALL SHTADV (A(M3),A(M3),A(M2),FACTOR,NEQS,1)
      CALL NEWDAV (A(N4),A(M3),A(N5),A(N1),A(M2),A(M3),A(M7),A(M8),
     1             A(N04),A(N05),NEQS,1)
      NN=M2 + NEQS*ITWO - 1
      WRITE (23) (A(I),I=M2,NN)
      NN=M7 + NEQS*ITWO - 1
      WRITE (23) (A(I),I=M7,NN)
      NN=M8 + NEQS * ITWO - 1
      WRITE (23) (A(I),I=M8,NN)
      M2=M2 + NEQS*ITWO
      M3=M3 + NEQS*ITWO
      M7=M7 + NEQS*ITWO
      M8=M8 + NEQS*ITWO
      NREC17=NREC17 + NSTE
  100 CONTINUE
      NREC16=NREC16 + NBLOCS + 1
  200 CONTINUE
      ISUB=0
      FACTOR=0.
      IF (KLIN.GT.0) CALL SHTADV (A(N3),A(N3),A(N2),FACTOR,NEQ,1)
C
C     MASTER STRUCTURE CALCULATIONS
C     CALCULATE NEW DISP,VEL,ACC VECTORS AT
C     TIME=TSTART + KSTEP*DT
C
  300 CALL NEWDAV (A(N4),A(N3),A(N5),A(N1),A(N2),A(N3),A(N7),A(N8),
     1             A(N04),A(N05),NEQ,1)
      RETURN
      END
C *CDC* *DECK NEWDAV
C *UNI* )FOR,IS  N.NEWDAV, R.NEWDAV
      SUBROUTINE NEWDAV (AA,R,DISPIS,DISPM,DISP,DISPI,VEL,ACC,NOD,
     1                   PRDIS,NEQ,IFLAG)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE NEW DISPLACEMENTS, VELOCITIES, AND            .
C .        ACCELERATIONS AT TIME T+DELTA(T)                           .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      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 /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 /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /SOL/ NUMNP,NUMEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /MDFRDM/ IDOF(6)
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /ULJ/ IULJ
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
C
      DIMENSION AA(1),R(1),DISPIS(1),DISPM(1),DISP(1),DISPI(1),VEL(1),
     1          ACC(1),NOD(1),PRDIS(1)
C
      IF (IFLAG.EQ.2) GO TO 118
      IF (ISTAT.GE.1) GO TO 10
C
C
C     S T A T I C S
C
C
      IF (KLIN.GT.0) GO TO 60
C
C     LINEAR ANALYSIS
C
      DO 50 I=1,NEQ
   50 DISP(I)=DISPI(I)
      GO TO 70
C
C     NONLINEAR ANALYSIS
C
   60 DO 40 I=1,NEQ
   40 DISP(I)=DISP(I) + DISPI(I)
   70 GO TO 200
C
C
C     D Y N A M I C S
C
C
   10 IF (KLIN.GT.0 .OR. IOPE.EQ.3) GO TO 90
      IF (IMODES.GT.0) GO TO 90
C
C     LINEAR ANALYSIS
C
      DO 80 I=1,NEQ
   80 DISPI(I)=DISPI(I) - DISP(I)
C
C     NONLINEAR ANALYSIS
C
   90 GO TO (91,101,111,200), IOPE
C
C     W I L S O N   M E T H O D
C
   91 DO 100 I=1,NEQ
      UTT=ACC(I)
      UUT=VEL(I)
      ACC(I) =A6 *DISPI(I)+A7 *UUT+A8 *UTT
      VEL(I) =UUT + A9*(ACC(I) + UTT)
      DISP(I)=DISP(I) + DT*UUT + A10*(ACC(I) + 2.*UTT)
  100 CONTINUE
      GO TO 200
C
C     N E W M A R K   M E T H O D
C
  101 DO 102 I=1,NEQ
      UTT=ACC(I)
      UUT=VEL(I)
      ACC(I) =A6 *DISPI(I)+A7 *UUT+A8 *UTT
      VEL(I) =UUT + A9*UTT + A10*ACC(I)
      DISP(I)=    DISPI(I)+DISP(I)
  102 CONTINUE
      GO TO 200
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
  111 IF (KSTEP.LT.NSTE .AND. NPDIS.GT.0) GO TO 220
      DO 112 I=1,NEQ
  112 DISPI(I)=R(I)/AA(I)
      GO TO 113
C
  220 READ (13) (PRDIS(I),I=1,NPDIS)
      NP=1
      NN=NOD(NP)
      DO 250 I=1,NEQ
      IF (I - NN) 240,230,240
  230 DISPI(I)=PRDIS(NP)
      IF (NPDIS.EQ.NP) GO TO 250
      NP=NP + 1
      NN=NOD(NP)
      GO TO 250
  240 DISPI(I)=R(I)/AA(I)
  250 CONTINUE
C
  113 IF (IPRI.NE.0 .AND. KPLOTN.NE.0) GO TO 200
      IF (IVC.EQ.0 .AND. JVC.EQ.0) GO TO 115
      DO 114 I=1,NEQ
  114 VEL(I)=A1*(DISPI(I) - DISPM(I))
  115 IF (IAC.EQ.0 .AND. JAC.EQ.0) GO TO 200
      DO 116 I=1,NEQ
  116 ACC(I)=A0*(DISPM(I) - 2.*DISP(I) + DISPI(I))
      GO TO 200
C
C     UPDATE DISPLACEMENT VECTOR
C
  118 DO 120 I=1,NEQ
      DISPM(I)=DISP(I)
  120 DISP(I)=DISPI(I)
      IF (IULJ.EQ.0) RETURN
      DO 130 I=1,NEQ
  130 DISPIS(I)=DISP(I) - DISPM(I)
C
  200 RETURN
C
      END
C *CDC* *DECK CONDIS
C *UNI* )FOR,IS N.CONDIS, R.CONDIS
      SUBROUTINE CONDIS (NID,IDI,BETA,DISP,VEL,ACC,NIDM,KKK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   PROGRAM .                                                       .
C .      . TO CALCULATE DISP (VEL/ACC) AT CONSTRAINED DOF             .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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
      COMMON /DISCON/ NDISCE,NIDMA
C
      DIMENSION NID(1),IDI(NIDM,1),BETA(NIDM,1),DISP(1),VEL(1),ACC(1)
C
      ISV=1
      ISA=1
      IF (IOPE.NE.3) GO TO 10
      ISV=(IVC + JVC + 1)/2
      ISA=(IAC + JAC + 1)/2
C
   10 DO 120 I=1,NDISCE
      K=NEQ + I
      ND=NID(I)
      DISP(K)=0.
      IF (KKK.EQ.0) GO TO 30
      IF (IOPE.EQ.3 .AND. ISV.EQ.0) GO TO 20
      VEL(K)=0.
   20 IF (IOPE.EQ.3 .AND. ISA.EQ.0) GO TO 30
      ACC(K)=0.
   30 DO 110 J=1,ND
      II=IDI(J,I)
      FAC=BETA(J,I)
      DISP(K)=DISP(K) + FAC*DISP(II)
      IF (KKK) 110,110,100
  100 IF (IOPE.EQ.3 .AND. ISV.EQ.0) GO TO 105
      VEL(K)=VEL(K) + FAC*VEL(II)
  105 IF (IOPE.EQ.3 .AND. ISA.EQ.0) GO TO 110
      ACC(K)=ACC(K) + FAC*ACC(II)
  110 CONTINUE
C
  120 CONTINUE
C
      RETURN
      END
C *CDC* *DECK,NORMAL
C *UNI* FOR,IS N.NORMAL R.NORMAL
      SUBROUTINE NORMAL (MIDSS,FMIDSS,FMV1,DISPI,ID,NDOF,KNOR)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .       TO UPDATE THE NODAL POINT NORMAL VECTOR TO MID-SURFACE      .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /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 /MIDSYS/NMIDSS,MIDIND,MAXMSS
      COMMON /MDFRDM/ IDOF(6)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,IREF,
     1             IEQUIT,IPRI,KPLOTN,KPLOTE
C
      DIMENSION MIDSS(1),FMIDSS(3,1),FMV1(3,1),DISPI(1),ID(NDOF,1)
      DATA RECLB1/8HNEWNORMS/
      XTOL=1.0D-8
C
      REWIND 8
      READ (8) ((ID(I,J),I=1,NDOF),J=1,NUMNP)
      IF (KNOR-1)1,1,6
C
C
C     INITIAL FMV1 IS GOING TO BE CALCULATED
C
C     AND STORED ON TAPE 9
C
C
    1 CONTINUE
      REWIND 9
      READ(9)((FMIDSS(I,J),I=1,3),J=1,MAXMSS)
      DO 2 J=1,MAXMSS
      VN1=FMIDSS(1,J)
      VN2=FMIDSS(2,J)
      VN3=FMIDSS(3,J)
      TEMP=DABS(VN2)-1.
      TEMP=DABS(TEMP)
      IF(TEMP-XTOL)3,3,4
C
C     S P E C I A L  C A S E
C     VNI PARALLEL TO Y-AXIS
C
    3 FMV1(1,J)=0.
      FMV1(2,J)=0.
      FMV1(3,J)=1.
      GO TO 2
C
C     S T A N D A R D  C A S E
C     VNI NOT PARALLEL TO Y-AXIS
C
    4 DUM=DSQRT(VN1*VN1+VN3*VN3)
      DUMI=1./DUM
      FMV1(1,J)=VN3*DUMI
      FMV1(2,J)=0.
      FMV1(3,J)= -VN1*DUMI
    2 CONTINUE
      GO TO 100
C
C
C     UPDATE THE NORMAL AT NODES WHICH ARE CONNECTED TO
C
C     GEOMETRICALLY NONLINEAR ELEMENTS
C
C
    6 CONTINUE
      JA=4
      JB=5
C
      DO 5 I=1,3
      IF (IDOF(I).EQ.0) GO TO 5
      JA=JA - 1
      JB=JB - 1
    5 CONTINUE
      IF (IDOF(4).GT.0) JA=0
      IF (JA.EQ.0) JB=JB - 1
      IF (IDOF(5).GT.0) JB=0
      JC=JA + JB
      IF (JC.EQ.0) GO TO 100
C
      REWIND 9
      READ(9)  ((FMIDSS(I,J),FMV1(I,J),I=1,3),J=1,MAXMSS)
      DO 50 I=1,MAXMSS
      II=MIDSS(I)
      DANG1=0.
      DANG2=0.
      IF(JA) 14,14,13
   13 J1=ID(JA,II)
      IF (J1.LT.0) J1=NEQ - J1
      IF (J1.GT.0) DANG1=DISPI(J1)
   14 IF (JB) 12,12,11
   11 J2=ID(JB,II)
      IF (J2.LT.0) J2=NEQ - J2
      IF (J2.GT.0) DANG2=DISPI(J2)
C
   12 CONTINUE
      REFANG=0.01
      INTER=DABS(DANG1)/REFANG
      INT2 =DABS(DANG2)/REFANG
      IF(INT2.GT.INTER) INTER=INT2
      IF(INTER.GT.20) INTER=20
      IF(INTER.LT.1) INTER=1
      XINTER=INTER
      DANG1=DANG1/XINTER
      DANG2=DANG2/XINTER
      DO 50 IIN=1,INTER
      VN1=FMIDSS(1,I)
      VN2=FMIDSS(2,I)
      VN3=FMIDSS(3,I)
C
      V11=FMV1(1,I)
      V12=FMV1(2,I)
      V13=FMV1(3,I)
C
      V21=VN2*V13-VN3*V12
      V22=VN3*V11-VN1*V13
      V23=VN1*V12-VN2*V11
      DUM=DSQRT(V21*V21+V22*V22+V23*V23)
      DUMI=1./DUM
      V21=V21*DUMI
      V22=V22*DUMI
      V23=V23*DUMI
C
C     UPDATE THE TEMPORARY NORMAL VECTOR
C
      VN1R=VN1-DANG1*V21+DANG2*V11
      VN2R=VN2-DANG1*V22+DANG2*V12
      VN3R=VN3-DANG1*V23+DANG2*V13
      DUM=DSQRT(VN1R*VN1R+VN2R*VN2R+VN3R*VN3R)
      DUMI=1./DUM
      FMIDSS(1,I)=VN1R*DUMI
      FMIDSS(2,I)=VN2R*DUMI
      FMIDSS(3,I)=VN3R*DUMI
C
C     UPDATE THE TEMPORARY V1 VECTOR
C
      V11R=V11-DANG2*VN1
      V12R=V12-DANG2*VN2
      V13R=V13-DANG2*VN3
      DUM=DSQRT(V11R*V11R+V12R*V12R+V13R*V13R)
      DUMI=1./DUM
      FMV1(1,I)=V11R*DUMI
      FMV1(2,I)=V12R*DUMI
      FMV1(3,I)=V13R*DUMI
   50 CONTINUE
C
C     VN AND V1 CORRESPONDING TO EQUILIBRIUM POSITIONS
C     ARE STORED ON TAPE 9
C
  100 IF (ICOUNT.EQ.3) RETURN
      REWIND 9
      WRITE(9) ((FMIDSS(I,J),FMV1(I,J),I=1,3),J=1,MAXMSS)
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB1
      IF (JNPORT.EQ.0 .OR. KPLOTN.NE.0) RETURN
      IF (JDC.NE.0)  WRITE (LUNODE) RECLAB,MAXMSS,
     1                ((FMIDSS(I,J),I=1,3),J=1,MAXMSS)
C
C***  DATA PORTHOLE (END)
C
      RETURN
      END
C *CDC* *DECK WRITE
C *UNI* )FOR,IS  N.WRITE,  R.WRITE
      SUBROUTINE WRITE (DISPE,DISP,VEL,ACC,ID,IDOF,ISUB,NEQ,NDOF,KKK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO READ INITIAL CONDITIONS INTO CORE AND                   .
C .        PRINT THEM (IF IPRIC.EQ.1)                                 .
C .                                                                   .
C .      . TO PRINT DISPLACEMENTS AND (IF ISTAT.NE.0)                 .
C .        VELOCITIES AND ACCELERATIONS                               .
C .                                                                   .
C .        KKK.EQ.0 READ INITIAL CONDITIONS FROM TAPE8                .
C .        KKK.EQ.1 PRINT INITIAL CONDITIONS FOR ALL DOF
C .        KKK.EQ.2, DURING TIME INTEGRATION PRINT DISP/VEL/ACC       .
C .                  AT NODES CONTAINED IN PRINT-OUT BLOCKS           .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NUMEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /ISUBST/ ISUS,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      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 /PRGCON/ IC,NTU
      COMMON /ELSTP/ TIME,IDTHF
      DIMENSION DISPE(NEQ),DISP(NEQ),VEL(NEQ),ACC(NEQ),ID(NDOF,1),D(6)
     1         ,IDOF(6)
      DATA RECLB1/8HNEW STEP/,RECLB2/8HDISP-XYZ/,RECLB3/8HVELOCITY/
      DATA RECLB4/8HACCLERTN/
C
      IF (KKK.EQ.1) GO TO 45
      IF (ISUB.GT.0 .AND. KKK.NE.0) GO TO 50
      IF (ISUB.GT.0) GO TO 10
C
C     READ ID ARRAY INTO CORE
C
      REWIND 8
      READ(8) ((ID(I,J),I=1,NDOF),J=1,NUMNP)
      IF (KKK.EQ.2) GO TO 50
C
C     READ INITIAL CONDITIONS INTO CORE
C
   10 IF (MODEX.EQ.2) RETURN
      READ (8) DISP
      IF (ISTAT.EQ.0) GO TO 40
      IF (IOPE.EQ.3) GO TO 20
      READ (8) VEL
      READ (8) ACC
      GO TO 40
C
   20 READ (8) DISPE
      ISV=(IVC + JVC + 1)/2
      ISA=(IAC + JAC + 1)/2
      IF (ISV.EQ.0) READ (8)
      IF (ISV.NE.0) READ (8) VEL
      IF (ISA.NE.0) READ (8) ACC
C
   40 RETURN
C
C     PRINT INITIAL CONDITIONS AT ALL NODES
C
   45 NODE1=1
      NODE2=NUMNP
      NODINC=1
      IF (IPRIC.EQ.0) GO TO 50
      WRITE (6,2100)
      IF (NSUBST.EQ.0) GO TO 50
      IF (ISUB.EQ.1) GO TO 48
      WRITE (6,2210)
      GO TO 50
   48 WRITE (6,2220) NSUB,NTU
      NODE2=NUMNPS
C
C     PRINT DISPLACEMENTS
C
   50 NEQT = NEQ
C
C***  DATA PORTHOLE (START)
C
      IF (JNPORT.EQ.0 .OR. KPLOTN.NE.0) GO TO 55
      RECLAB = RECLB1
      WRITE (LUNODE) RECLAB,KSTEP,TIME,NUMNP,ISTAT,(IDOF(I),I=1,6),NSUB
      RECLAB = RECLB2
      IF (JDC.NE.0) WRITE (LUNODE) RECLAB,NEQT,(DISP(I),I=1,NEQT)
      IF (ISTAT.EQ.0) GO TO 55
      RECLAB = RECLB3
      IF (JVC.NE.0) WRITE (LUNODE) RECLAB,NEQT,(VEL(I),I=1,NEQT)
      RECLAB = RECLB4
      IF (JAC.NE.0) WRITE (LUNODE) RECLAB,NEQT,(ACC(I),I=1,NEQT)
C
C***  DATA PORTHOLE (END)
C
   55 IF (IPRIC.EQ.0 .AND. KSTEP.EQ.0) RETURN
      IF (IPRI.NE.0 .AND. KSTEP.GT.0) RETURN
      IF (KKK.EQ.1) GO TO 60
      IF (IDC.EQ.0) GO TO 180
   60 WRITE (6,2000)
      IC=IC + 5
      DO 150 IB=1,NPB
      IF (KKK.EQ.1) GO TO 104
      NODE1=IPNODE(1,IB)
      NODE2=IPNODE(2,IB)
      NODINC=IPNODE(3,IB)
C
  104 DO 100 II=NODE1,NODE2,NODINC
      IC=IC + 1
      IF (IC.LT.56) GO TO 105
      WRITE(6,2045)
      IC=4
  105 DO 110 I=1,6
  110 D(I)=0.
      IL=0
      DO 120 I=1,NDOF
      KK=ID(I,II)
      IF(KK.LT.0) KK=NUMEQ - KK
  115 IL=IL + 1
      IF (IL.LE.6) GO TO 117
      WRITE (6,3000)
      STOP
  117 IF (IDOF(IL).EQ.1) GO TO 115
      IF (KK.NE.0) D(IL)=DISP(KK)
  120 CONTINUE
  100 WRITE(6,2010) II,D
C
      IF (KKK.EQ.1) GO TO 180
      IF (IC.GE.55) GO TO 150
      IC=IC+1
      WRITE(6,2050)
  150 CONTINUE
  180 IF (ISTAT.EQ.0) GO TO 380
C
C     PRINT VELOCITIES
C
      IF (KKK.EQ.1 .AND. IOPE.NE.3) GO TO 201
      IF (IVC.EQ.0) GO TO 280
  201 IC=IC + 5 + IDC
      IF (IDC.NE.0) WRITE(6,2050)
      IF (IC.GE.54) GO TO 205
      WRITE(6,2020)
      GO TO 206
  205 WRITE(6,2022)
      IC=4
  206 DO 250 IB=1,NPB
      IF (KKK.EQ.1) GO TO 204
      NODE1=IPNODE(1,IB)
      NODE2=IPNODE(2,IB)
      NODINC=IPNODE(3,IB)
C
  204 DO 200 II=NODE1,NODE2,NODINC
      IC=IC + 1
      IF (IC.LT.56) GO TO 207
      WRITE(6,2022)
      IC=4
  207 DO 210 I=1,6
  210 D(I)=0.
      IL=0
      DO 220 I=1,NDOF
      KK=ID(I,II)
      IF(KK.LT.0) KK=NUMEQ - KK
  215 IL=IL + 1
      IF (IL.LE.6) GO TO 217
      WRITE (6,3000)
      STOP
  217 IF (IDOF(IL).EQ.1) GO TO 215
  220 IF (KK.NE.0) D(IL)=VEL(KK)
  200 WRITE(6,2010) II,D
C
      IF (KKK.EQ.1) GO TO 280
      IF (IC.GE.55) GO TO 250
      IC=IC+1
      WRITE(6,2050)
  250 CONTINUE
C
C     PRINT ACCELERATIONS
C
  280 IF (KKK.EQ.1 .AND. IOPE.NE.3) GO TO 290
      IF (IAC.EQ.0) GO TO 380
      IF (IDC.EQ.0 .AND. IVC.EQ.0) GO TO 305
  290 IC=IC + 6
      IF (IC.GE.54) GO TO 303
      WRITE(6,2050)
      WRITE(6,2030)
      GO TO 308
  303 WRITE(6,2032)
      IC=4
      GO TO 308
  305 IC=IC + 5
      WRITE(6,2030)
  308 DO 350 IB=1,NPB
      IF (KKK.EQ.1) GO TO 304
      NODE1=IPNODE(1,IB)
      NODE2=IPNODE(2,IB)
      NODINC=IPNODE(3,IB)
C
  304 DO 300 II=NODE1,NODE2,NODINC
      IC=IC + 1
      IF (IC.LT.56) GO TO 307
      WRITE(6,2032)
      IC=4
  307 DO 310 I=1,6
  310 D(I)=0.
      IL=0
      DO 320 I=1,NDOF
      KK=ID(I,II)
      IF(KK.LT.0) KK=NUMEQ - KK
  315 IL=IL + 1
      IF (IL.LE.6) GO TO 317
      WRITE (6,3000)
      STOP
  317 IF (IDOF(IL).EQ.1) GO TO 315
  320 IF (KK.NE.0) D(IL)=ACC(KK)
  300 WRITE(6,2010) II,D
C
      IF (KKK.EQ.1) RETURN
      IF (IC.GE.55) GO TO 350
      IC=IC+1
      WRITE(6,2050)
  350 CONTINUE
C
  380 RETURN
C
 2000 FORMAT (/27H  D I S P L A C E M E N T S  // 7H  NODE 12X
     114HX-DISPLACEMENT 4X 14HY-DISPLACEMENT 4X 14HZ-DISPLACEMENT
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2010 FORMAT (2X,I5,8X,6E18.6)
 2020 FORMAT(/22H  V E L O C I T I E S  // 7H  NODE 16X 10HX-VELOCITY
     18X 10HY-VELOCITY 8X 10HZ-VELOCITY
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2022 FORMAT (1H1,21H V E L O C I T I E S   //7H  NODE 16X 10HX-VELOCITY
     18X 10HY-VELOCITY 8X 10HZ-VELOCITY
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2030 FORMAT (/27H  A C C E L E R A T I O N S  // 7H  NODE 12X
     114HX-ACCELERATION 4X 14HY-ACCELERATION 4X 14HZ-ACCELERATION
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2032 FORMAT (1H1,26H A C C E L E R A T I O N S  // 7H  NODE 12X
     114HX-ACCELERATION 4X 14HY-ACCELERATION 4X 14HZ-ACCELERATION
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2045 FORMAT (1H1, 26H D I S P L A C E M E N T S  // 7H  NODE 12X
     114HX-DISPLACEMENT 4X 14HY-DISPLACEMENT 4X 14HZ-DISPLACEMENT
     24X,14HX(V1)-ROTATION,4X,14HY(V2)-ROTATION,4X,14HZ(VN)-ROTATION  /)
 2050 FORMAT (1H )
 2100 FORMAT (1H1,38H I N I T I A L   C O N D I T I O N S     ///)
 2210 FORMAT (5X,17H MASTER STRUCTURE,/ )
 2220 FORMAT (5X,14H SUBSTRUCTURES ,//,
     1 22H SUBSTRUCTURE NUMBER =,I5,20X,28H IDENTIFICATION SET NUMBER =,
     2 I5//)
 3000 FORMAT (///48H **STOP, ERROR IN DEGREE OF FREEDOM CALCULATIONS,/,
     1           28H CHECK MASTER CONTROL CARD 1  ,/1X)
C
      END
C *CDC* *DECK WRITEM
C *UNI* )FOR,IS N.WRITEM,R.WRITEM
      SUBROUTINE WRITEM (TIME,TEMP,NUMNP,KKK)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION TEMP(1)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /PORTT/ JTC
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /TICON/ IPRIT
      DATA RECLB1/8HTEMPERAT/
C
      DATA ICOL /4/, NLINE /50/
C
      IF (KKK.GT. 1) GO TO 200
C
C***  DATA PORTHOLE (START)
C
      IF (JNPORT.EQ.0 .OR. KPLOTN.NE.0 .OR. JTC.EQ.0) GO TO 10
      RECLAB = RECLB1
      WRITE (LUNODE) RECLAB,(TEMP(I),I=1,NUMNP)
C
C***  DATA PORTHOLE (END)
C
   10 IF (IPRIT.EQ.0 .AND. KSTEP.EQ.0) RETURN
      IF (KSTEP.GT.0) RETURN
C
C     PRINT INITIAL TEMPERATURES
C
      WRITE (6,2000) TIME
C
      K1 = 0
      ILINE = 0
      IPAGES = NUMNP/(ICOL*NLINE)
      IF (IPAGES.EQ.0) GO TO 40
C
      DO 25 IP=1,IPAGES
      IF (IP.EQ.1) GO TO 15
      WRITE (6,2010)
C
   15 DO 20   J=1, NLINE
      K1=K1+1
      K2=K1+NLINE
      K3=K2+NLINE
      K4=K3+NLINE
      WRITE (6,2100) K1,TEMP(K1),K2,TEMP(K2),K3,TEMP(K3),K4,TEMP(K4)
   20 CONTINUE
      K1=K4
   25 CONTINUE
C
      IF (K1.EQ.NUMNP) GO TO 100
C
   40 ILINE = (NUMNP-K1)/ICOL
      IF (ILINE.EQ.0) GO TO 70
C
      DO 60 IL=1,ILINE
      K1=K1+1
      K2=K1+ILINE
      K3=K2+ILINE
      K4=K3+ILINE
      WRITE (6,2100) K1,TEMP(K1),K2,TEMP(K2),K3,TEMP(K3),K4,TEMP(K4)
   60 CONTINUE
      K1=K4
      IF (K1.EQ.NUMNP) GO TO 100
C
   70 K1=K1+1
      IF (NUMNP.LE.3) GO TO 80
      WRITE (6,2110) (K,TEMP(K),K=K1,NUMNP)
      GO TO 100
   80 WRITE (6,2120) (K,TEMP(K),K=K1,NUMNP)
C
C
  100 RETURN
  200 RETURN
C
 2000 FORMAT (1H1,63HI N I T I A L   N O D A L   P O I N T   T E M P E R
     1 A T U R E S, 24X,10H(AT TIME =,E12.6,1H)//
     2        4(5H NODE,5X,11HTEMPERATURE,9X)/)
 2010 FORMAT (1H1/5H NODE,5X,11HTEMPERATURE,
     1        3(9X,5H NODE,5X,11HTEMPERATURE)/)
 2100 FORMAT (I4,E17.6,3(9X,I4,E17.6))
 2110 FORMAT (90X,I4,E17.6)
 2120 FORMAT (I4,E17.6)
C
      END
C *CDC* *DECK STRESS
C *UNI* )FOR,IS  N.STRESS, R.STRESS
      SUBROUTINE STRESS (EE,ISUB,NEGL,NEGNL)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALL THE ELEMENT SUBROUTINE FOR THE CALCULATION OF      .
C .        STRESSES                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
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,NGEL,NGENL,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 /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 /DISCON/ NDISCE,NIDM
      COMMON /DPR/ ITWO
      COMMON /RANDI/ N0A,N1D,IELCPL
      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 A(1)
      DIMENSION EE(1)
      REAL EE,A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      NG=0
C
C
C     L I N E A R   E L E M E N T   G R O U P S
C
C
      IF (NEGL.EQ.0) GO TO 200
C
      IF (ISUB.EQ.0) REWIND 1
C
      DO 100 N=1,NEGL
      NG=NG + 1
      READ (1) NUMEST,(EE(I),I=1,NUMEST)
      CALL ELEMNT
  100 CONTINUE
C
C
C     N O N L I N E A R   E L E M E N T   G R O U P S
C
C
  200 IF (NEGNL.EQ.0) RETURN
C
      DO 300 N=1,NEGNL
      NG=NG + 1
      NUMEST=IA(N0 + N - 1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC2=N
      CALL READMS (2,EE,NUMEST,NREC2)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      CALL ELEMNT
  300 CONTINUE
C
      RETURN
      END
C *CDC* *DECK COLHT
C *UNI* )FOR,IS  N.COLHT,  R.COLHT
      SUBROUTINE COLHT (MHT,ND,LM)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DISCON/ NDISCE,NIDM
      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
      DIMENSION LM(1),MHT(1)
      COMMON A(1)
      REAL A
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      LS=NEQ + 1
      IF (ISUB.NE.0) LS=NEQS + 1
      DO 100 I=1,ND
      IF (LM(I)) 50,100,80
C
   50 NCE=-LM(I)
      NID=IA(N01 + NCE - 1)
      II=N02 + (NCE - 1)*NIDM - 1
      DO 70 J=1,NID
      JJ=IA(II + J)
      IF (JJ - LS) 60,70,70
   60 LS=JJ
   70 CONTINUE
      GO TO 100
C
   80 IF (LM(I) - LS) 90,100,100
   90 LS=LM(I)
C
  100 CONTINUE
C
      DO 200 I=1,ND
      II=LM(I)
      IF (II) 150,200,190
C
  150 NCE=-II
      NID=IA(N01 + NCE - 1)
      JJ=N02 + (NCE - 1)*NIDM - 1
      DO 160 J=1,NID
      II=IA(JJ + J)
      ME=II - LS
      IF (ME.GT.MHT(II)) MHT(II)=ME
  160 CONTINUE
C
  190 ME=II - LS
      IF (ME.GT.MHT(II)) MHT(II)=ME
 200  CONTINUE
C
      RETURN
      END
C *CDC* *DECK MODMHT
C *UNI* )FOR,IS N.MODMHT, R.MODMHT
      SUBROUTINE MODMHT (M,ID,MHT,IDS,ICONA,LMS,NDOF,NDOFSS,NUMNP)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .      . PROGRAM                                                    .
C .          TO READ SUBSTRUCTURE CONNECTIVITY ARRAYS AND             .
C .          TO MODIFY COLUMN HEIGHTS OF MASTER DOF DUE TO THE        .
C .          ADDITION OF SUBSTRUCTURES                                .
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 /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /LOACHK/ LSC
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /SOL/ NUMPN,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
C
      DIMENSION ID(NDOF,1),MHT(1),ICONA(1),LMS(1),DIRNUM(9),VEC(2)
      DIMENSION IDS(NDOFSS,1),ISPRIB(3,10),ISPNOD(3,15),BLKNAM(1)
      DATA BLKNAM /8HPRINTOUT/
      DATA VEC(1)/3H X /, VEC(2)/3H Y /
      DATA RECLB1/8HICONARAY/
C
C     READ SUBSTRUCTURE IDENTIFICATION DATA SET NO M
C
      READ (5,1000) N,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,
     1              NPSHS,IPRTPS
      NXYZ=0
      IF (N.EQ.M) GO TO 20
      WRITE (6,3000) NSUB,M,N
      STOP
C
   20 NODE3S=12
      IF (IDATWR.GT.1) GO TO 30
      IF (M.EQ.1) WRITE (6,2000)
      IF (M.NE.1) WRITE (6,2010)
      WRITE(6,2020)N,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,
     1             NPSHS
C
C     READ AND CHECK DIRECTION RATIOS OF THE LOCAL COORDINATE SYSTEM
C
   30 DO 32 I=1,9
   32 DIRNUM(I)=0.
      IF (NXYZ.EQ.0) GO TO 40
      READ (5,1010) (DIRNUM(I),I=1,6)
      IF (IDATWR.LE.1) WRITE (6,2030) (DIRNUM(I),I=1,6)
      TOL=2.D-02
      TEMP=DSQRT(DIRNUM(1)*DIRNUM(1) + DIRNUM(2)*DIRNUM(2) +
     1                   DIRNUM(3)*DIRNUM(3))
      IF (TEMP.GT.TOL) GO TO 34
      WRITE (6,3010) VEC(1)
      STOP
   34 DO 35 I=1,3
   35 DIRNUM(I)=DIRNUM(I)/TEMP
C
      TEMP=DSQRT(DIRNUM(4)*DIRNUM(4) + DIRNUM(5)*DIRNUM(5) +
     1                   DIRNUM(6)*DIRNUM(6))
      IF (TEMP.GT.TOL) GO TO 36
      WRITE (6,3010) VEC(2)
      STOP
   36 DO 37 I=1,3
   37 DIRNUM(I)=DIRNUM(I)/TEMP
C
      XDY=0.
      DO 38 I=1,3
   38 XDY=XDY + DIRNUM(I)*DIRNUM(I + 3)
      IF (XDY.LT.1.D-06) GO TO 39
      WRITE (6,3015) VEC(1),VEC(2)
      STOP
   39 CALL CROSS (DIRNUM(1),DIRNUM(4),DIRNUM(7))
C
C     REPLACE MASTER LOAD DATA BY SUBSTRUCTURE LOAD DATA
C
   40 LSC=1
      CALL LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,NPSHS,
     1             NODE3S,2)
      CALL STORE (NUMNPS,NDOFS,NEQS,NWKS,MAS,NEGNLS,MAXES,NBLOCS,
     1            ISTOHS,1)
C
C     ESTABLISH LMS ARRAY
C
      READ (5,1000) (ICONA(I),I=1,NODRET)
      IF (IDATWR.LE.1) WRITE (6,2040) (I,ICONA(I),I=1,NODRET)
C
C
C***  DATA PORTHOLE (START)
C
      RECLAB = RECLB1
      IF (JNPORT.NE.0 .AND. NPUTSV.NE.0)
     1  WRITE (LUNODE) RECLAB,(ICONA(I),I=1,NODRET)
C
C***  DATA PORTHOLE (END)
C
      JJ=0
      DO 50 I=1,NODRET
      NN=ICONA(I)
      IF (NN.GT.0 .AND. NN.LE.NUMNP) GO TO 45
      WRITE (6,3020) NSUB,I,ICONA(I)
      STOP
   45 DO 50 J=1,NDOFS
      KK=IDS(J,NODCON+I)
      IF (KK.EQ.0) GO TO 50
      II=ID(J,NN)
      JJ=JJ + 1
      LMS(JJ)=II
   50 CONTINUE
      ND=JJ
C
C     UPDATE MASTER STRUCTURE COLUMN HEIGHTS
C
      ISSUB=ISUB
      ISUB=0
      CALL COLHT (MHT,ND,LMS)
      ISUB=ISSUB
C
C     READ SUBSTRUCTURE RESPONSE PRINT-OUT CONTROL PARAMETERS
C
      READ (5,1000)  NSPRIB,NSPB
      IF (IDATWR.LE.1) WRITE (6,2100) NSPRIB,NSPB
C
      ISC=1
      IF (NSPRIB .EQ.0) GO TO 470
      READ (5,1100)((ISPRIB(I,J),I=1,3),J=1,NSPRIB)
      IF (NSTE.GT.0 .AND. ISPRIB(1,1).EQ.0) ISPRIB(1,1)=1
      IF ( ISPRIB(2,1) .EQ. 0)  ISPRIB(2,1) = NSTE
      IF ( ISPRIB(3,1) .EQ. 0)  ISPRIB(3,1) = 1
      INDEX=1
      IF (NSPRIB.LE.1) GO TO 440
      DO 430 I=2,NSPRIB
      J=I - 1
      IF (ISPRIB(1,J).GT.ISPRIB(2,J)) GO TO 435
      IF (ISPRIB(1,I).GE.ISPRIB(2,J)) GO TO 430
      WRITE (6,3002) BLKNAM(INDEX),I,J
      STOP
  430 CONTINUE
  440 J=NSPRIB
      IF (ISPRIB(1,J).LE.ISPRIB(2,J)) GO TO 445
  435 WRITE (6,3004) BLKNAM(INDEX),J,J
      STOP
  445 IF (ISPRIB(2,NSPRIB).GE.NSTE) GO TO 450
      WRITE (6,3001) BLKNAM(INDEX),ISPRIB(2,NSPRIB),NSTE
      STOP
C
  450 IF (IDATWR.GT.1) GO TO 470
      WRITE (6,2160)
      WRITE (6,2170) (J,(J,ISPRIB(I,J),I=1,3),J=1,NSPRIB)
  470 IF (IOUTPT.NE.0) GO TO 480
      NSPRIB=1
      ISPRIB(1,1)=1
      ISPRIB(2,1)=NSTE
      ISPRIB(3,1)=1
      GO TO 490
  480 IF (NSPRIB.NE.0) GO TO 490
      ISC=0
      NSPRIB=1
      ISPRIB(1,1)=NSTE + 1
      ISPRIB(2,1)=NSTE + 1
      ISPRIB(3,1)=1
  490 IF (NSPB.EQ.0) ISC=0
      IF (IOUTPT.EQ.0) ISC=1
C
      IF (NSPB.EQ.0) GO TO 570
      READ (5,1100) ((ISPNOD(I,J),I=1,3),J=1,NSPB)
      IF (ISPNOD(1,1).EQ.0) ISPNOD(1,1)=1
      IF (ISPNOD(2,1).EQ.0) ISPNOD(2,1)=NUMNPS
      IF (ISPNOD(3,1).LE.0) ISPNOD(3,1)=1
      DO 500 I=1,NSPB
      IF (ISPNOD(1,I).LT.0) GO TO 510
      IF (ISPNOD(1,I).GT.ISPNOD(2,I)) GO TO 510
      IF (ISPNOD(3,I).LE.0) GO TO 510
  500 CONTINUE
      GO TO 550
  510 WRITE (6,2990)
      STOP
  550 IF (IDATWR.GT.1) GO TO 570
      WRITE (6,2180)
      WRITE (6,2190) (J,(J,ISPNOD(I,J),I=1,3),J=1,NSPB)
C
  570 IF (IOUTPT.NE.0 .AND. NSPB.GT.0) GO TO 600
      NSPB=1
      ISPNOD(1,1)=1
      ISPNOD(2,1)=NUMNPS
      ISPNOD(3,1)=1
C
  600 WRITE (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1               NPPLS,NPSHS,NODE3S,
     1               (DIRNUM(I),I=1,9),ND,(LMS(I),I=1,ND),ISC,NSPRIB,
     2               NSPB,((ISPRIB(I,J),I=1,3),J=1,NSPRIB),
     3               ((ISPNOD(I,J),I=1,3),J=1,NSPB)
C
      RETURN
C
 1000 FORMAT (16I5)
 1010 FORMAT (8F10.0)
 1100 FORMAT (15I5,5X)
 2000 FORMAT (1H1,63HS U B S T R U C T U R E   I D E N T I F I C A T I O
     1 N   D A T A   )
 2010 FORMAT (1H1)
 2020 FORMAT (///5X,
     155HIDENTIFICATION SET NUMBER . . . . . . . . .( N )      =,I5//5X,
     555HINDICATOR FOR REUSE OF LOAD VECTOR . . . . (LREUSE)   =,I5 /5X,
     655H  EQ.0, LOADS FOR THIS SUBSTRUCTURE ARE THE SAME AS        /5X,
     A55H        THE LOADS FOR THE PREVIOUS SUBSTRUCTURE            /5X,
     A55H        ( NOT APPLICABLE, IF N.EQ.1 )                      /5X,
     B55H  EQ.1, LOADS FOR THIS SUBSTRUCTURE ARE DIFFERENT FROM     /5X,
     C55H        THE LOADS FOR THE PREVIOUS SUBSTRUCTURE           //5X,
     755HNUMBER OF CONCENTRATED LOAD CARDS . . . . .(NLOADS)   =,I5//5X,
     855HNUMBER OF 2/D PRESSURE LOAD SETS . . . . . (NPR2S)    =,I5//5X,
     955HNUMBER OF 3/D PRESSURE LOAD SETS . . . . . (NPR3S)    =,I5//5X,
     455HNUMBER OF BEAM DISTRIBUTED LOAD SETS . . . (NPBMS)    =,I5//5X,
     D55HNUMBER OF ISO/BEAM DISTRIBUTED LOAD SETS . (NP3DBS)   =,I5//5X,
     E55HNUMBER OF PLATE DISTRIBUTED LOAD SETS  . . (NPPLS)    =,I5//5X,
     F55HNUMBER OF SHELL DISTRIBUTED LOAD SETS  . . (NPSHS)    =,I5//5X)
 2030 FORMAT (///23H DIRECTION RATIOS  DATA,//5X,
     152HDIRCTION RATIO  FOR LOCAL X-AXIS ON GLOBAL X-AXIS  =,F10.5//5X,
     152HDIRCTION RATIO  FOR LOCAL X-AXIS ON GLOBAL Y-AXIS  =,F10.5//5X,
     352HDIRCTION RATIO  FOR LOCAL X-AXIS ON GLOBAL Z-AXIS  =,F10.5//5X,
     452HDIRCTION RATIO  FOR LOCAL Y-AXIS ON GLOBAL X-AXIS  =,F10.5//5X,
     552HDIRCTION RATIO  FOR LOCAL Y-AXIS ON GLOBAL Y-AXIS  =,F10.5//5X,
     652HDIRCTION RATIO  FOR LOCAL Y-AXIS ON GLOBAL Z-AXIS  =,F10.5)
 2040 FORMAT (///32H SUBSTRUCTURE CONNECTIVITY DATA  //,
     1           4(21H     I       ICONA(I),9X ),/,(/4(I6,8X,I5,11X)))
 2100 FORMAT (///,
     151H SUBSTRUCTURE RESPONSE PRINT-OUT CONTROL PARAMETERS,//5X,
     255HNUMBER OF BLOCKS OF PRINT-OUT TIMESTEPS . . .(NSPRIB) =I5//5X,
     355HNUMBER OF BLOCKS OF PRINT-OUT NODAL POINTS. .( NSPB ) =I5 //)
 2160 FORMAT (/5X,47HBLOCK DEFINITION CARDS FOR PRINT-OUT TIME STEPS//5X
     159H( NOT APPLICABLE, IF IOUTPT.EQ.0 ON MASTER CONTROL CARD 8 )  )
 2170 FORMAT (/,4X,
     A  7H BLOCK ,I2                                               //7X,
     B 46H FIRST STEP OF THIS BLOCK  .  .  .  (ISPRIB(1,I2,3H))= I5 /7X,
     C 46H LAST  STEP OF THIS BLOCK  .  .  .  (ISPRIB(2,I2,3H))= I5 /7X,
     D 46H INCREMENT IN TIME STEP .  .  .  .  (ISPRIB(3,I2,3H))= I5 /)
 2180 FORMAT (/5X,48HBLOCK DEFINTION CARDS FOR PRINT-OUT NODAL POINTS//,
     15X,59H( NOT APPLICABLE, IF IOUTPT.EQ.0 ON MASTER CONTROL CARD 8 ))
 2190 FORMAT (/,4X,
     A  7H BLOCK ,I2                                               //7X,
     B 46H FIRST NODE OF THIS BLOCK  .  .  .  (ISPNOD(1,I2,3H))= I5 /7X,
     C 46H LAST  NODE OF THIS BLOCK  .  .  .  (ISPNOD(2,I2,3H))= I5 /7X,
     D 46H INCREMENT IN NODE NUMBER  .  .  .  (ISPNOD(3,I2,3H))= I5 /)
 2990 FORMAT (1H1,80H ** STOP **  ERROR IN INPUT OF BLOCK DEFINITIONS OF
     1  NODAL QUANTITIES PRINT-OUT  )
 3000 FORMAT (57H *** ERROR IN IDENTIFICATION SET INPUT FOR SUBSTRUCTURE
     1 =,I5/,38H EXPECTING IDENTIFICATION SET NUMBER =,I5/,
     234H INPUT IDENTIFICATION SET NUMBER =,I5//)
 3001 FORMAT(1H1,20H ** STOP ** ERROR IN,A8,2X,44HBLOCK INPUT.FINAL STEP
     1 OF LAST BLOCK INPUT =,I5,18H, LESS THAN NSTE =,I5)
 3002 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,
     1 9HTH BLOCK.  ///)
 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,
     1 9HTH BLOCK.  ///)
 3010 FORMAT (1H1,19H *** ERROR IN INPUT,/
     112H INPUT LOCAL,A3,23HVECTOR IS A ZERO VECTOR       )
 3015 FORMAT (1H1,19H *** ERROR IN INPUT  ,/
     112H INPUT LOCAL,A3,3HAND,A3,26HVECTORS ARE NOT ORTHOGONAL  )
 3020 FORMAT (57H *** ERROR IN CONNECTIVITY ARRAY INPUT FOR SUBSTRUCTURE
     1 =,I5/,27H FOR RETAINED NODE NUMBER =,I5/,
     235H CORRESPONDING GLOBAL NODE NUMBER =,I5,16H IS OUT OF RANGE  )
C
      END
C *CDC* *DECK SUBSKR
C *UNI* )FOR,IS N.SUBSKR, R.SUBSKR
      SUBROUTINE SUBSKR (BB,AA,CC,LMS,MAXA,NCOLBV,ISTOHS,NBLOCS,NREC16,
     1                   NREC17,KRSIZE,NEQ)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   PROGRAM                                                         .
C .    . TO EXTRACT CONDENSED SUBSTRUCTURE STIFFNESS MATRIX FROM      .
C .      THE TOTAL STIFFNESS MATRIX AND PERFORM TRANSFORMATIONS       .
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 /SOL/ NUMNP,NNN,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 /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /BLOCKS/ NSREFB,NEQITB,NPRIB,NODSVB,LEMSVB,ISREFB(3,10),
     1                IEQITB(3,10),IPRIB(3,10),INODB(3,10),IELMB(3,10)
      COMMON /SLOA/ N09C,ITMFN,ICOORD,NUSE
      COMMON /FACDBL/ JFAC
C
      DIMENSION BB(KRSIZE),AA(ISTOHS),CC(NEQ),DIRCOS(9)
      INTEGER LMS(1),MAXA(1),NCOLBV(1)
C
      IF (IND - 2) 10,700,850
C
C
C     S T I F F N E S S   T R A N S F O R M A T I O N
C
C
   10 DO 50 I=1,KRSIZE
   50 BB(I)=0.
C
      NRD=NEQS - NEQC
      NEQL=1
      NEQR=0
      MLA=0
      NREC16=NREC16 - NBLOCS - 1
C
      DO 450 L=1,NBLOCS
      NCOLB=NCOLBV(L)
      NEQR=NEQR + NCOLB
      NREC16=NREC16 + 1
      IF (NEQR.LE. NEQC) GO TO 440
C
C    * * * * * *    R A N D O M   A C C E S S     * * *
C
      CALL READMS (16,AA,ISTOHS,NREC16)
C
C    * * * * * *    R A N D O M   A C C E S S     * * *
C
      DO 435 I=NEQL,NEQR
      IF (I.LE.NEQC) GO TO 435
      J=I - NEQC
      JJ=MAXA(I + 1) - MAXA(I)
      KK=MIN0(JJ,J)
C
      N=0
      II=J
      IF (JJ.GE.J) GO TO 425
      N=J - JJ
      DO 420 K=1,N
  420 II=II + NRD - K
C
  425 JJ=MAXA(I) + KK - MLA
      DO 430 K=1,KK
      BB(II)=AA(JJ - K)
  430 II=II + NRD - K - N
C
  435 CONTINUE
  440 NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL) - 1
  450 CONTINUE
C
      REWIND 12
      WRITE (12) BB
      NREC16=NREC16 + 1
C
      DO 600 N=1,NTUSE
C
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S,
     1               (DIRCOS(I),I=1,9),ND,(LMS(I),I=1,ND)
C
C     READ KR MATRIX FROM TAPE12, TRANSFORM TO SYSTEM NXYZ AND WRITE
C     ONTO TAPE11
C
      WRITE (18) ND,(LMS(I),I=1,ND),KRSIZE,(BB(I),I=1,KRSIZE)
  600 CONTINUE
C
      RETURN
C
C
C     L O A D   V E C T O R   T R A N S F O R M A T I O N
C
C     TRNSFER MASTER STRUCTURE LOADS FROM TAPE 3 TO TAPE17
C
  700 IF (NSUB.NE.1) GO TO 730
      IF (MODEX.EQ.0 .OR. NSTE.EQ.0) GO TO 730
C
      REWIND 3
      NREC17=0
      DO 720 K=1,NSTE
      READ (3) CC
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
      NREC17=NREC17 + 1
      CALL WRITMS (17,CC,NEQ,NREC17,-1)
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
  720 CONTINUE
C
  730 DO 800 N=1,NTUSE
C
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S
      NUSE=N
      IF (N.EQ.1) GO TO 735
      IF (LREUSE.NE.0) GO TO 735
      IF (IDATWR.LE.1) WRITE (6,2100) NSUB,NUSE
      GO TO 740
  735 CONTINUE
C
C     REPLACE MASTER LOAD DATA BY SUBSTRUCTURE LOAD DATA
C
      CALL LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,NPSHS,
     1             NODE3S,2)
C
C *CDC*       CALL OVERLAY (5HADINA,17B,0B,6HRECALL)
      CALL LOAD
      IF (MODEX.EQ.0 .OR. NSTE.EQ.0) GO TO 740
      IF (ISTAT.GT.0) GO TO 750
C
C     TAKE REDUCED STIFFNESS MATRIX INTO CORE, IF ONE BLOCK CASE
C     AND STATIC ANALYSIS
C
      IF (NBLOCS.GT.1) GO TO 740
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
      KK=NREC16 + 1
      CALL READMS (16,AA,ISTOHS,KK)
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
  740 BACKSPACE NSTAPE
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S,
     1               (DIRCOS(I),I=1,9),ND,(LMS(I),I=1,ND)
C
  750 IF (MODEX.EQ.0 .OR. NSTE.EQ.0) GO TO 800
      REWIND 3
      DO 780 K=1,NSTE
      READ (3) BB
C
C     REDUCE LOAD VECTOR IF STATIC ANALYSIS
C
      IF (ISTAT.GT.0) GO TO 760
C
      CALL COLSOL (MAXA,NCOLBV,MAXA,AA,AA,BB,BB,MAXA,
     1             NEQS,NBLOCS,ISTOHS,12,16,2)
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC17=NREC17 + 1
      CALL WRITMS (17,BB,NEQC,NREC17,-1)
C
      KK=K
      CALL READMS (17,CC,NEQ,KK)
C
      NN=NEQC + 1
      JFAC=1
      CALL ADDMA (CC,BB(NN),LMS,ND)
      JFAC=0
C
      KK=K
      CALL WRITMS (17,CC,NEQ,KK,-1)
C
C     WRITE UNREDUCED SUBSTRUCTURE APPLIED LOAD VECTOR ONTO TAPE
C     IF IT IS A DYNAMIC ANALYSIS
C
  760 IF (ISTAT.EQ.0) GO TO 780
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
      NREC17=NREC17 + 1
      CALL WRITMS (17,BB,NEQS,NREC17,-1)
C
C   * * * * *    R A N D O M   A C C E S S   * * *
C
C
  780 CONTINUE
  800 CONTINUE
C
C       * * * * *        R A N D O M  A C C E S S        * * *
C
      IF (NSUB.NE.NSUBST) RETURN
C
C     TRANSFER MASTER LOADS BACK TO TAPE 3 FROM TAPE17
C
      IF (MODEX.EQ.0 .OR. NSTE.EQ.0) GO TO 830
      REWIND 3
      DO 820 K=1,NSTE
C
      KK=K
      CALL READMS (17,CC,NEQ,KK)
C
      WRITE (3) CC
C
  820 CONTINUE
C
C     REINSTATE MASTER LOAD CONTROL INFORMATION
C
  830 CONTINUE
      CALL LOADSV (ILOA,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,NPPLS,NPSHS,
     1             NODE3S,3)
C
      RETURN
C
C
C     D I S P L A C E M E N T   T R A N S F O R M A T I O N
C
C
  850 IF (IND.EQ.4) GO TO 862
C
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S,
     1              (DIRCOS(I),I=1,9),ND,(LMS(I),I=1,ND),ISC,NPRIB,
     2               NPB,((IPRIB(I,J),I=1,3),J=1,NPRIB),
     3               ((IPNODE(I,J),I=1,3),J=1,NPB)
      IF (ISC.NE.0) GO TO 860
      IPRI = 1
      KPRI = 1
      RETURN
C
C     FLAG FOR PRINTING NODAL AND ELEMENT RESPONSES
C        IPRI .EQ. 0 FOR PRINTOUT OF DISP,VEL,ACC AND STRESSES
C
  860 CALL BLKCNT (KSTEP,NPRIB,IPRI,IPRIB,NSTE,3)
      KPRI=IPRI
      RETURN
  862 IF (KSTEP.NE.1 .AND. ISTAT.EQ.0) GO TO 864
      READ (NSTAPE) NXYZ,LREUSE,NLOADS,NPR2S,NPR3S,NPBMS,NP3DBS,
     1              NPPLS,NPSHS,NODE3S,
     1              (DIRCOS(I),I=1,9),ND,(LMS(I),I=1,ND)
C
C     READ THE LOAD VECTOR
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
  864 CALL READMS (17,BB,NEQC,NREC17)
C
C     * * * * *    R A N D O M   A C C E S S      * * *
C
C     OBTAIN DISPLACEMENTS AT RETAINED DOF FROM MASTER DOF
C
      NRD=NEQS - NEQC
      DO 880 I=1,NRD
      II=LMS(I)
      JJ=NEQC + I
      IF (II) 865,870,875
  865 BB(JJ)=CC(NEQ - II)
      GO TO 880
  870 BB(JJ)=0.
      GO TO 880
  875 BB(JJ)=CC(II)
  880 CONTINUE
C
      RETURN
C
 2100 FORMAT (/////46H S U B S T R U C T U R E   L O A D S   D A T A   ,
     1//22H SUBSTRUCTURE NUMBER =,I3,24H IDENTIFICATION SET NO =,I3//,
     284H LOADS FOR THIS SUBSTRUCTURE ARE THE SAME AS THE LOADS FOR THE
     3PREVIOUS SUBSTRUCTURE //)
      END
C *CDC* *DECK ADDBAN
C *UNI* )FOR,IS  N.ADDBAN, R.ADDBAN
      SUBROUTINE ADDBAN (A,MAXA,S,RE,LM,ND,KKK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   EXECUTION MODE KKK=1                                            .
C .                                                                   .
C .   ASSEMBLES UPPER TRIANGULAR ELEMENT STIFFNESS INTO               .
C .         COMPACTED GLOBAL STIFFNESS                                .
C .                                                                   .
C .         A = GLOBAL STIFFNESS                                      .
C .         S = ELEMENT STIFFNESS                                     .
C .         ND = DEGREES OF FREEDOM IN ELEMENT STIFFNESS              .
C .                                                                   .
C .                   S(1)        S(2)        S(3)        . . .       .
C .         S   =                 S(ND+1)     S(ND+2)     . . .       .
C .                                           S(2*ND)     . . .       .
C .                                                       . . .       .
C .                                                                   .
C .                                                                   .
C .                   A(1)        A(3)        A(6)        . . .       .
C .         A   =                 A(2)        A(5)        . . .       .
C .                                           A(4)        . . .       .
C .                                                       . . .       .
C .                                                                   .
C .   EXECUTION MODE KKK=2                                            .
C .                                                                   .
C .   SUBTRACTS ELEMENT NODAL POINT FORCES EQUIVALENT TO ELEMENT      .
C .         STRESSES FROM EFFECTIVE LOADVECTOR                        .
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 /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /DPR/ ITWO
      COMMON AA(1)
      REAL AA
      INTEGER IA(1)
      EQUIVALENCE (AA(1),IA(1))
C
      DIMENSION A(1),S(1),RE(1)
      INTEGER MAXA(1),LM(1)
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
C
      IF (KKK-1) 10,10,300
C
   10 NDI=0
      DO 200 I=1,ND
      II=LM(I)
      IF (II.GE.0) GO TO 100
C
C     ADD THE COLUMN OF ELEMENT STIFFNESS  (CONSTRAINED DOF)
C
      NCE=-II
      NID=IA(N01 + NCE - 1)
      NN=N02 + (NCE - 1)*NIDM - 1
      MM=N03 + ((NCE - 1)*NIDM - 1)*ITWO
      DO 50 K=1,NID
      II=IA(NN + K)
      IF (II.LT.NEQL .OR. II.GT.NEQR) GO TO 50
      FAC=DOUBLE(AA(MM + K*ITWO))
C
      MI=MAXA(II) - MLA
      KS=I
      DO 30 J=1,ND
      JJ=LM(J)
      IF (JJ) 11,30,15
   11 MCE=-JJ
      MID=IA(N01 + MCE - 1)
      LL=N02 + (MCE - 1)*NIDM - 1
      KL=N03 + ((MCE - 1)*NIDM - 1)*ITWO
      KSS=KS
      IF(J.GE.I) KSS=J + NDI
      DO 14 L=1,MID
      JJ=IA(LL + L)
      IJ=II - JJ
      IF (IJ) 14,12,12
   12 KK=MI + IJ
      FACT=DOUBLE(AA(KL + L*ITWO))
      A(KK)=A(KK) + FAC*S(KSS)*FACT
   14 CONTINUE
      GO TO 30
C
   15 IJ=II- JJ
      IF (IJ) 30,20,20
   20 KK=MI + IJ
      KSS=KS
      IF (J.GE.I) KSS=J + NDI
      A(KK)=A(KK) + S(KSS)*FAC
   30 KS=KS + ND - J
   50 CONTINUE
      GO TO 200
C
C     ADD THE I TH COLUMN OF ELEMENT STIFFNESS MATRIX TO GLOBAL STIFFNES
C
  100 IF (II.LT.NEQL .OR. II.GT.NEQR) GO TO 200
      MI=MAXA(II) - MLA
      KS=I
      DO 220 J=1,ND
      JJ=LM(J)
      IF (JJ) 110,220,190
C
C     ROW ADDITION OF STIFFNESS MATRIX (CONSTRAINED DOF)
C
  110 NCE=-JJ
      NID=IA(N01 + NCE - 1)
      NN=N02 + (NCE - 1)*NIDM - 1
      MM=N03 + ((NCE - 1)*NIDM - 1)*ITWO
      KSS=KS
      IF (J.GE.I) KSS=J + NDI
      DO 150 K=1,NID
      JJ=IA(NN + K)
      FAC=DOUBLE(AA(MM + K*ITWO))
C
      IJ=II- JJ
      IF (IJ) 150,120,120
  120 KK=MI + IJ
      A(KK)=A(KK) + S(KSS)*FAC
  150 CONTINUE
      GO TO 220
C
C     ADD THE J TH ROW OF ELEMENT STIFFNESS MATRIX TO GLOBAL STIFFNESS
C
  190 IJ=II - JJ
      IF (IJ) 220,210,210
 210  KK=MI + IJ
      KSS=KS
      IF (J.GE.I) KSS=J + NDI
      A(KK)=A(KK) + S(KSS)
  220 KS=KS + ND - J
  200 NDI=NDI + ND - I
C
      RETURN
C
  300 DO 310 I=1,ND
      II=LM(I)
      IF (II) 320,310,350
C
C     TRANSFER NODAL FORCES FROM CONSTRAINED DOF
C
  320 NCE=-II
      NID=IA(N01 + NCE - 1)
      NN=N02 + (NCE - 1)*NIDM - 1
      MM=N03 + ((NCE - 1)*NIDM - 1)*ITWO
      DO 330 J=1,NID
      II=IA(NN + J)
      IF (II.LT.NEQL .OR. II.GT.NEQR) GO TO 330
      FAC=DOUBLE(AA(MM + J*ITWO))
      A(II)=A(II) - FAC*RE(I)
  330 CONTINUE
      GO TO 310
C
  350 IF (II.LT.NEQL .OR. II.GT.NEQR) GO TO 310
      A(II)=A(II) - RE(I)
  310 CONTINUE
      RETURN
C
      END
C *CDC* *DECK DOUBLE
C *UNI* )FOR,IS N.DOUBLE,R.DOUBLE
      FUNCTION DOUBLE (A)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DOUBLE=A
C
      RETURN
      END
C *CDC* *DECK ATKA
C *UNI* )FOR,IS N.ATKA,R.ATKA
      SUBROUTINE ATKA (RSDCOS,S,ISKEW,NODES,NDPN)
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),ISKEW(1),S(1),WS(9)
C
C     CHECK IF CALCULATIONS ARE FOR A SHELL ,
C     AND DETERMINE THE SIZE OF S
C
      IF (NPAR(1).EQ.7) GO TO 8
      DO 5 I=1,NODES
    5 LMID(I)=1
C
    8 IDIM=0
      DO 10 I=1,NODES
      IDIM=IDIM + NDPN
      IF (LMID(I).LT.0) IDIM=IDIM + 2
   10 CONTINUE
C
      JUMD=0
C
      DO 25 K=1,NODES
      IN=K
      IF (ISKEW(IN)) 30,25,50
   25 IF (LMID(K).LT.0) JUMD=JUMD + 2
   30 RETURN
C
   50 ISTAR=1
      IF (NDPN.EQ.2) ISTAR=2
C
C
      DO 400 I=IN,NODES
      IRST=ISKEW(I)
C
C     IF THE I-TH NODE DOES NOT BELONG TO ANY SKEW SYSTEM,
C     SKIP THE TRANSFORMATION CALCULATIONS FOR ALL THE ROWS
C     CORRESPONDING TO THIS NODE FOR THE PRESENT
C
      IF (IRST.EQ.0) GO TO 400
C
      IDF=NDPN*(I-1) + JUMD
      IFL=1 + IDF*IDIM - (IDF*(IDF-1))/2
      LEN=IDIM - IDF
      ISL=IFL + LEN
C
C     TRANSFER DIAGONAL SUBMATRIX (NDPN X NDPN) OF NODE I TO WORK VECTOR
C
      IF (NDPN.EQ.3) GO TO 70
      WS(5)=S(IFL)
      WS(8)=S(IFL+1)
      WS(6)=WS(8)
      WS(9)=S(ISL)
      GO TO 80
C
   70 ITL=ISL + LEN - 1
      WS(1)=S(IFL)
      WS(4)=S(IFL+1)
      WS(7)=S(IFL+2)
      WS(2)=WS(4)
      WS(5)=S(ISL)
      WS(8)=S(ISL+1)
      WS(3)=WS(7)
      WS(6)=WS(8)
      WS(9)=S(ITL)
C
C     PRE AND POST MULTIPLY THE DIAGONAL SUBMATRIX BY THE IRST SYSTEM
C
   80 IPER=0
      CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,IRST),ISTAR,IPER)
C
      IF (NDPN.EQ.3) GO TO 90
      S(IFL)=WS(5)
      S(IFL+1)=WS(8)
      S(ISL)=WS(9)
      GO TO 95
C
   90 S(IFL)=WS(1)
      S(IFL+1)=WS(4)
      S(IFL+2)=WS(7)
      S(ISL)=WS(5)
      S(ISL+1)=WS(8)
      S(ITL)=WS(9)
   95 CONTINUE
C
      IF (I.EQ.NODES) GO TO 205
C
C     ROTATE THE I-TH ROW -  PRE-MULTIPLY BY THE IRST SYSTEM.   ALSO
C     POST-MULTIPLY IF THE J-TH NODE BELONGS TO THE JRST SKEW SYSTEM
C
      JN=I+1
      JUMR=0
C
      DO 200 J=JN,NODES
      IF (LMID(J-1).LT.0) JUMR=JUMR + 2
      IRL=IFL + NDPN*(J-I) + JUMR
      ISL=IRL + LEN -1
      IF (NDPN.EQ.3) GO TO 120
      WS(5)=S(IRL)
      WS(8)=S(IRL+1)
      WS(6)=S(ISL)
      WS(9)=S(ISL+1)
      GO TO 130
C
  120 MM=-1
      ITL=ISL + LEN - 2
      DO 125 M=1,7,3
      MM=MM + 1
      WS(M)=S(IRL+MM)
      WS(M+1)=S(ISL+MM)
  125 WS(M+2)=S(ITL+MM)
C
  130 IPER=-1
      JRST=ISKEW(J)
      IF (JRST) 140,140,150
  140 CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,IRST),ISTAR,IPER)
      GO TO 155
  150 IPER=0
      CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,JRST),ISTAR,IPER)
C
  155 IF (NDPN.EQ.3) GO TO 160
      S(IRL)=WS(5)
      S(IRL+1)=WS(8)
      S(ISL)=WS(6)
      S(ISL+1)=WS(9)
      GO TO 200
  160 MM=-1
      DO 170 M=1,7,3
      MM=MM + 1
      S(IRL+MM)=WS(M)
      S(ISL+MM)=WS(M+1)
  170 S(ITL+MM)=WS(M+2)
C
  200 CONTINUE
C
C     PREMULTIPLY THE COUPLING PART BETWEEN TRANSLATION AND ROTATION DOF
C
  205 IF (NPAR(1).NE.7) GO TO 208
C
      JN=I
      JUMR=0
      IPER=-1
      DO 190 J=JN,NODES
      JUMR=JUMR + 3
      IF (LMID(J).GE.0) GO TO 190
      IRL=IFL + JUMR
      ISL=IRL + LEN - 1
      ITL=ISL + LEN - 2
      WS(1)=S(IRL)
      WS(2)=S(ISL)
      WS(3)=S(ITL)
      WS(4)=S(IRL + 1)
      WS(5)=S(ISL + 1)
      WS(6)=S(ITL + 1)
      WS(7)=0.
      WS(8)=0.
      WS(9)=0.
C
      CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,IRST),ISTAR,IPER)
C
      S(IRL)=WS(1)
      S(ISL)=WS(2)
      S(ITL)=WS(3)
      S(IRL + 1)=WS(4)
      S(ISL + 1)=WS(5)
      S(ITL + 1)=WS(6)
      JUMR=JUMR + 2
  190 CONTINUE
C
C     POST-MULTIPLY COUPLING PART BETWEEN ROTATION AND TRANSLATION DOF
C
      IF (I.EQ.NODES) GO TO 208
      IF (LMID(I).GE.0) GO TO 208
      JN=I + 1
      JUMR=0
      IRL=IFL + LEN + LEN-1 + LEN-2 + 2
      ISL=IRL + LEN-4
      IPER=1
      DO 198 J=JN,NODES
      JRST=ISKEW(J)
      IRL=IRL + JUMR
      ISL=ISL + JUMR
      IF (JRST.EQ.0) GO TO 195
      WS(1)=S(IRL)
      WS(2)=S(ISL)
      WS(3)=0.
      WS(4)=S(IRL + 1)
      WS(5)=S(ISL + 1)
      WS(6)=0.
      WS(7)=S(IRL + 2)
      WS(8)=S(ISL + 2)
      WS(9)=0.
C
      CALL TRIPRD (RSDCOS(1,JRST),WS,RSDCOS(1,JRST),ISTAR,IPER)
C
      S(IRL)=WS(1)
      S(ISL)=WS(2)
      S(IRL + 1)=WS(4)
      S(ISL + 1)=WS(5)
      S(IRL + 2)=WS(7)
      S(ISL + 2)=WS(8)
  195 JUMR=3
      IF (LMID(J).LT.0) JUMR=5
  198 CONTINUE
C
  208 JF=I - 1
      IF (JF.LE.0) GO TO 400
C
C     POST-MULTIPLY THE COLUMNS BELONGING TO THE J-TH NODE,
C     IF THE J-TH NODE DOES NOT BELONG TO ANY SKEW SYSTEM
C
      IPER=1
      JUMV=0
C
      DO 300 J=1,JF
      JRST=ISKEW(J)
      JM1=J - 1
      IF (JM1.LE.0) GO TO 210
      IF (LMID(JM1).LT.0) JUMV=JUMV + 2
  210 IF (JRST) 215,215,300
C
  215 JUMH=0
      DO 216 KF=J,JF
  216 IF (LMID(KF).LT.0) JUMH=JUMH + 2
C
      IDF=NDPN*(J-1) + JUMV
      IFL=1 + IDF*IDIM - (IDF*(IDF-1))/2 + NDPN*(I-J) + JUMH
      LEN=IDIM-IDF
      ISL=IFL+LEN-1
      IF (NDPN.EQ.3) GO TO 220
      WS(5)=S(IFL)
      WS(8)=S(IFL+1)
      WS(6)=S(ISL)
      WS(9)=S(ISL+1)
      GO TO 230
  220 MM=-1
      ITL=ISL + LEN - 2
      DO 225 M=1,7,3
      MM=MM+1
      WS(M)=S(IFL+MM)
      WS(M+1)=S(ISL+MM)
  225 WS(M+2)=S(ITL+MM)
C
  230 CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,IRST),ISTAR,IPER)
C
      IF (NDPN.EQ.3) GO TO 260
      S(IFL)=WS(5)
      S(IFL+1)=WS(8)
      S(ISL)=WS(6)
      S(ISL+1)=WS(9)
      GO TO 280
C
  260 MM=-1
      DO 270 M=1,7,3
      MM=MM+1
      S(IFL+MM)=WS(M)
      S(ISL+MM)=WS(M+1)
  270 S(ITL+MM)=WS(M+2)
C
C
C     POST-MULTIPLY COUPLING PART BETWEEN ROTATION AND TRANSLATION DOF
C     BELONGING TO THE J-TH NODE, IF THE J-T8 NO45 4O5S NOT 25LON7
C     TO ANY SKEW SYSTEM
C
  280 IF (NPAR(1).NE.7) GO TO 300
C
      IRL=ITL + LEN - 3
      ISL=IRL + LEN - 4
      WS(1)=S(IRL)
      WS(2)=S(ISL)
      WS(3)=0.
      WS(4)=S(IRL+1)
      WS(5)=S(ISL+1)
      WS(6)=0.
      WS(7)=S(IRL+2)
      WS(8)=S(ISL+2)
      WS(9)=0.
C
      CALL TRIPRD (RSDCOS(1,IRST),WS,RSDCOS(1,IRST),ISTAR,IPER)
C
      MM=-1
      DO 350 M=1,7,3
      MM=MM+1
      S(IRL+MM)=WS(M)
  350 S(ISL+MM)=WS(M+1)
C
  300 CONTINUE
C
C
  400 IF (LMID(I).LT.0) JUMD=JUMD + 2
C
C
C
      RETURN
C
C
      END
C *CDC* *DECK TRIPRD
C *UNI* )FOR,IS TRIPRD,R.TRIPRD
      SUBROUTINE TRIPRD (AI,WS,AJ,ISF,IPER)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AI(3,1),WS(3,1),AJ(3,1),D(3,3)
C
C     IPER = -1, PREMULT WS BY TRANSPOSE OF AI
C             1, POSTMULTIPLY WS BY AJ
C             0, BOTH PRE- AND POST-MULTIPLICATION
C
C
      IF (IPER.LT.0) GO TO 40
C
C     POST - MULTIPLICATION
C
      DO 25 I=ISF,3
      DO 25 J=ISF,3
      D(I,J)=0.
      DO 20 K=ISF,3
   20 D(I,J)=D(I,J) + WS(I,K)*AJ(K,J)
   25 CONTINUE
C
      IF (IPER.EQ.0) GO TO 60
C
C     POST-MULTIPLICATION ONLY
C
      DO 30 I=ISF,3
      DO 30 J=ISF,3
   30 WS(I,J)=D(I,J)
      RETURN
C
C     PRE - MULTIPLICATION
C
   40 DO 50 I=ISF,3
      DO 50 J=ISF,3
   50 D(I,J)=WS(I,J)
C
   60 DO 75 I=ISF,3
      DO 75 J=ISF,3
      WS(I,J)=0.
      DO 70 K=ISF,3
   70 WS(I,J)=WS(I,J) + AI(K,I)*D(K,J)
   75 CONTINUE
C
      RETURN
C
C
      END