C *CDC* *DECK MATWRF
C *UNI* )FOR,IS  N.MATWRF, R.MATWRF
      SUBROUTINE MATWRF (N,DEN,PROP)
C
C
C     PROGRAM TO PRINT FLUID PROPERTIES
C     FOR THREE-DIMENSIONAL FLUID ELEMENTS
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      DIMENSION PROP(1)
      EQUIVALENCE (NPAR(15),MODEL),(NPAR(16),NUMMAT),(NPAR(17),NCON),
     1            (NPAR(20),IDW)
C
C
      IF (IDATWR.GT.1) RETURN
      WRITE(6,2100) N,DEN
C
      GO TO (1,1,1,1,1,1),MODEL
C
C
C.... MODEL = 1    C O N S T A N T  B U L K  M O D U L U S
C
    1 WRITE(6,2101) (PROP(I), I=1,NCON)
      RETURN
C
C
C
 2100 FORMAT (27H FLUID CONSTANTS SET NUMBER,6H .... ,I5//,
     1        1H ,4X,29HDEN ..........( DENSITY ).. =, E14.6/)
 2101 FORMAT (1H ,4X,29HK ............( PROP(1) ).. =, E14.6///)
C
C
      END
C *CDC* *DECK FQUADS
C *UNI* )FOR,IS  N.FQUADS, R.FQUADS
      SUBROUTINE FQUADS (ND,B,S,XYZ,PROP,RE,EDIS,WA,NOD9)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .                                                                   .
C .      HEXAHEDRAL CURVILINEAR THREE-DIMENSIONAL FLUID ELEMENTS      .
C .                                                                   .
C .      ISOPARAMETRIC OR SUBPARAMETRIC                               .
C .                                                                   .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION B(1),S(1),XYZ(1),PROP(1),RE(1),EDIS(1),WA(1),NOD9(1)
      DIMENSION DISD(9),TAU(6),XXX(63)
C
      EQUIVALENCE (NPAR(3),INDNL),(NPAR(10),NINT),(NPAR(11),NINTZ),
     1            (NPAR(15),MODEL)
C
C
      IF (IND.GE.4) GO TO 100
C
C
C     F I N D  S T I F F N E S S  O F
C     L I N E A R  F L U I D  E L E M E N T
C
C
C
C     INTEGRATE B(TRANSPOSED) * B
C
      DO 30 LX=1,NINT
      E1=XG(LX,NINT)
      DO 30 LY=1,NINT
      E2=XG(LY,NINT)
      DO 30 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      WT=WGT(LX,NINT)*WGT(LY,NINT)*WGT(LZ,NINTZ)
C
C     EVALUATE STRAIN-DISPLACEMENT MATRIX B AND JACOBIAN DETERMINANT
C     AT THIS INTEGRATION POINT
C
      CALL FDERIQ (NEL,XYZ,B,DET,E1,E2,E3,NOD9)
C
      PROPK=PROP(1)
      FAC=WT*DET*PROPK
      FAC=DSQRT(FAC)
      DO 10 I=1,ND
 10   B(I)=FAC*B(I)
      KL=0
      DO 20 I=1,ND
      DO 20 J=I,ND
      KL=KL+1
 20   S(KL)=S(KL)+B(I)*B(J)
 30   CONTINUE
C
C
      RETURN
C
C
C     C A L C U L A T E  N O N L I N E A R
C     F L U I D  E L E M E N T  M A T R I C E S
C
C
  100 CONTINUE
      DO 105 J=1,ND
  105 XXX(J)=XYZ(J)
      IF (INDNL.EQ.0) GO TO 140
      DO 110 J=1,ND
 110  XXX(J)=XYZ(J)+EDIS(J)
C
C
C     CALCULATE FLUID STIFFNESS MATRIX AND
C     AND ELEMENT NODAL FORCES
C
C
  140 IPT=0
      DO 470 LX=1,NINT
      E1=XG(LX,NINT)
      DO 470 LY=1,NINT
      E2=XG(LY,NINT)
      DO 470 LZ=1,NINTZ
      E3=XG(LZ,NINTZ)
      WT=WGT(LX,NINT)*WGT(LY,NINT)*WGT(LZ,NINTZ)
      IPT=IPT+1
C
C
C     U P D A T E D    L A G R A N G I A N    F O R M U L A T I O N
C
C
C     EVALUATE DERIVATIVE OPERATOR B (IN COMPACTED FORM)
C
      CALL FDERIQ (NEL,XXX,B,DET,E1,E2,E3,NOD9)
C
C
      DO 320 I=1,9
 320  DISD(I)=0.0
C
C     CALCULATE DISPLACEMENT DERIVATIVES
C
      DO 330 J=3,ND,3
      I=J-1
      K=J-2
      DISD(1)=DISD(1)+B(K)*EDIS(K)
      DISD(2)=DISD(2)+B(I)*EDIS(I)
      DISD(3)=DISD(3)+B(J)*EDIS(J)
      DISD(4)=DISD(4)+B(I)*EDIS(K)
      DISD(5)=DISD(5)+B(J)*EDIS(K)
      DISD(6)=DISD(6)+B(K)*EDIS(I)
      DISD(7)=DISD(7)+B(J)*EDIS(I)
      DISD(8)=DISD(8)+B(K)*EDIS(J)
 330  DISD(9)=DISD(9)+B(I)*EDIS(J)
C
C     EVALUATE CURRENT PRESSURES
C
      CALL STST3F (DISD,PRESS,PROP)
C
C     ADD PRESSURE CONTRIBUTION TO ELEMENT FORCE VECTOR
C
      FAC=WT*DET
      TAU(1)=-PRESS*FAC
      DO 350 I=1,ND
      RE(I)=RE(I)+B(I)*TAU(1)
  350 CONTINUE
C
      IF (ICOUNT-2) 360,360,470
 360  IF (IREF) 470,370,470
C
C     ADD LINEAR CONTRIBUTION TO ELEMENT STIFFNESS MATRIX
C
  370 PROPK=PROP(1)
      FAC=WT*DET*PROPK
      KL=0
      DO 380 I=1,ND
      DO 380 J=I,ND
      KL=KL+1
  380 S(KL)=S(KL) + B(I)*B(J)*FAC
C
C     ADD NONLINEAR CONTRIBUTION TO STIFFNESS MATRIX
C
      IF (INDNL.EQ.0 .OR. TAU(1).EQ.0.) GO TO 470
      KL=1
      DO 491 J=1,ND,3
      DB1=TAU(1)*B(J)
      DB2=TAU(1)*B(J+1)
      DB3=TAU(1)*B(J+2)
      KS1=KL
      KS2=KS1+ND-J+1
      KS3=KS2+ND-J
      DO 490 I=J,ND,3
      DUM=B(I)*DB1 + B(I+1)*DB2 + B(I+2)*DB3
      S(KS1)=S(KS1) + DUM
      S(KS2)=S(KS2) + DUM
      S(KS3)=S(KS3) + DUM
      KS1=KS1+3
      KS2=KS2+3
  490 KS3=KS3+3
  491 KL=KL+3*ND-3*J
C
  470 CONTINUE
C
      RETURN
C
C
      END
C *CDC* *DECK FQUADM
C *UNI* )FOR,IS  N.FQUADM, R.FQUADM
      SUBROUTINE FQUADM  (N,ND,NDM2,XM,CM,XX,NOD9)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      EVALUATES FLUID MASS MATRIX                                  .
C .                                                                   .
C .      CURVILINEAR HEXAHEDRON   8 TO 21 NODES                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      DIMENSION XM(1),CM(1),XX(3,1),D(63),NOD9(1)
      DIMENSION H(21),P(3,21),XJ(3,3)
C
C
C     INTEGRATE USING GAUSS QUADRATURE
C
C
      IINTP=0
      NINTM=3
      NINTZM=3
      IF (IMASS.EQ.1) GO TO 9
      DO 8 I=1,NDM2
    8 CM(I)=0.0
      GO TO 10
    9 DO 7 I=1,ND
    7 XM(I)=0.
C
   10 DO 900 LX=1,NINTM
      R=XG(LX,NINTM)
      DO 900 LY=1,NINTM
      S=XG(LY,NINTM)
      DO 900 LZ=1,NINTZM
      T=XG(LZ,NINTZM)
      WT=WGT(LX,NINTM)*WGT(LY,NINTM)*WGT(LZ,NINTZM)
C
C
C     FIND INTERPOLATION FUNCTIONS
C     FIND JACOBIAN MATRIX AND ITS DETERMINANT
C
C
      CALL FFUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C     CONSISTENT MASS MATRIX
C
C
      FAC=WT*DET*DE
      IF (IMASS.LT.2) GO TO 320
      DO 200 I=1,IEL
      D(3*I - 2)=H(I)
      D(3*I - 1)=H(I)
  200 D(3*I)=H(I)
      KL=1
      DO 300 I=1,ND,3
      DO 301 J=I,ND,3
      CM(KL)=CM(KL) + D(I)*D(J)*FAC
  301 KL=KL + 3
  300 KL=KL + 2*(ND-I) - 1
      GO TO 900
C
C
C     LUMPED MASS VECTOR
C
C
  320 DO 325 I=1,ND,3
      FACM=FAC/IEL
  325 XM(I)=XM(I) + FACM
C
  900 CONTINUE
C
      IF (IMASS.EQ.1) GO TO 335
      KL=1
      DO 450 I=1,ND,3
      KS1=KL + ND - I + 1
      KS2=KS1 + ND - I
      DO 451 J=I,ND,3
      CM(KS1)=CM(KL)
      CM(KS2)=CM(KL)
      KL=KL + 3
      KS1=KS1 + 3
  451 KS2=KS2 + 3
  450 KL=KL + 2*(ND-I) - 1
      RETURN
C
  335 DO 340 I=1,ND,3
      XM(I+1)=XM(I)
  340 XM(I+2)=XM(I)
      RETURN
      END
C *CDC* *DECK FDERIQ
C *UNI* )FOR,IS  N.FDERIQ, R.FDERIQ
      SUBROUTINE FDERIQ  (NEL,XX,B,DET,R,S,T,NOD9)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      EVALUATES STRAIN-DISPLACEMENT MATRIX B AT POINT (R,S,T)      .
C .                                                                   .
C .      CURVILINEAR HEXAHEDRON   8 TO 21 NODES                       .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      DIMENSION XX(3,1),B(1),NOD9(1)
      DIMENSION H(21),P(3,21),XJ(3,3),XJI(3,3)
C
C
C     FIND INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     EVALUATE JACOBIAN MATRIX AT POINT (R,S,T)
C     COMPUTE DETERMINANT OF JACOBIAN MATRIX AT POINT (R,S,T)
C
C
      IINTP=0
      CALL FFUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C     COMPUTE INVERSE OF JACOBIAN MATRIX
C
C
      DUM=1.0/DET
      XJI(1,1)=DUM*( XJ(2,2)*XJ(3,3) - XJ(2,3)*XJ(3,2))
      XJI(2,1)=DUM*(-XJ(2,1)*XJ(3,3) + XJ(2,3)*XJ(3,1))
      XJI(3,1)=DUM*( XJ(2,1)*XJ(3,2) - XJ(2,2)*XJ(3,1))
      XJI(1,2)=DUM*(-XJ(1,2)*XJ(3,3) + XJ(1,3)*XJ(3,2))
      XJI(2,2)=DUM*( XJ(1,1)*XJ(3,3) - XJ(1,3)*XJ(3,1))
      XJI(3,2)=DUM*(-XJ(1,1)*XJ(3,2) + XJ(1,2)*XJ(3,1))
      XJI(1,3)=DUM*( XJ(1,2)*XJ(2,3) - XJ(1,3)*XJ(2,2))
      XJI(2,3)=DUM*(-XJ(1,1)*XJ(2,3) + XJ(1,3)*XJ(2,1))
      XJI(3,3)=DUM*( XJ(1,1)*XJ(2,2) - XJ(1,2)*XJ(2,1))
C
C
C     EVALUATE B MATRIX IN GLOBAL (X,Y,Z) COORDINATES
C
C
      DO 130 K=1,IEL
      K2=K*3
      DO 125 I=1,3
  125 B(K2+1-I)=0.0
      DO 120 I=1,3
      B(K2-2)=B(K2-2) + XJI(1,I)*P(I,K)
      B(K2-1)=B(K2-1) + XJI(2,I)*P(I,K)
  120 B(K2)=B(K2) + XJI(3,I)*P(I,K)
  130 CONTINUE
C
C
      RETURN
C
      END
C *CDC* *DECK FFUNCT
C *UNI* )FOR,IS  N.FFUNCT,  R.FFUNCT
      SUBROUTINE FFUNCT (R,S,T,H,P,NOD9,XJ,DET,XX,IINTP)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .                                                                   .
C .      TO FIND INTERPOLATION FUNCTIONS ( H )                        .
C .      AND DERIVATIVES ( P ) CORRESPONDING TO THE NODAL             .
C .      POINTS OF A CURVILINEAR ISOPARAMETRIC HEXAHEDRON             .
C .      OR SUBPARAMETRIC HEXAHEDRON (8 TO 21 NODES)                  .
C .                                                                   .
C .      TO FIND JACOBIAN ( XJ ) AND ITS DETERMINANT ( DET )          .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /VAR/   NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,IREF,
     1               IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,
     1            ISTAT,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
      DIMENSION H(1),P(3,1),NOD9(1),IPERM(8),XJ(3,3),XX(3,1)
      EQUIVALENCE (NPAR(8),IDEGEN)
C
      DATA IPERM / 2,3,4,1,6,7,8,5 /
C
      RP=1.0 + R
      SP=1.0 + S
      TP=1.0 + T
      RM=1.0 - R
      SM=1.0 - S
      TM=1.0 - T
      RR=1.0 - R*R
      SS=1.0 - S*S
      TT=1.0 - T*T
C
C
C     INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C
C
C     8-NODE BRICK
C
      H(1)=0.125*RP*SP*TP
      H(2)=0.125*RM*SP*TP
      H(3)=0.125*RM*SM*TP
      H(4)=0.125*RP*SM*TP
      H(5)=0.125*RP*SP*TM
      H(6)=0.125*RM*SP*TM
      H(7)=0.125*RM*SM*TM
      H(8)=0.125*RP*SM*TM
C
      P(1,1)= 0.125*SP*TP
      P(1,2)=-P(1,1)
      P(1,3)=-0.125*SM*TP
      P(1,4)=-P(1,3)
      P(1,5)= 0.125*SP*TM
      P(1,6)=-P(1,5)
      P(1,7)=-0.125*SM*TM
      P(1,8)=-P(1,7)
C
      P(2,1)= 0.125*RP*TP
      P(2,2)= 0.125*RM*TP
      P(2,3)=-P(2,2)
      P(2,4)=-P(2,1)
      P(2,5)= 0.125*RP*TM
      P(2,6)= 0.125*RM*TM
      P(2,7)=-P(2,6)
      P(2,8)=-P(2,5)
C
      P(3,1)= 0.125*RP*SP
      P(3,2)= 0.125*RM*SP
      P(3,3)= 0.125*RM*SM
      P(3,4)= 0.125*RP*SM
      P(3,5)=-P(3,1)
      P(3,6)=-P(3,2)
      P(3,7)=-P(3,3)
      P(3,8)=-P(3,4)
C
      IF (IEL.EQ.8) GO TO 80
C
C
C     ADD DEGREES OF FREEDOM IN EXCESS OF 8
C
      I=0
    2 I=I + 1
      IF (I.GT.NND9) GO TO 40
      NN=NOD9(I) - 8
      GO TO (9,10,11,12,13,14,15,16,17,18,19,20,21) ,NN
C
    9 H(9) =0.25*RR*SP*TP
      P(1,9) =-0.50*R*SP*TP
      P(2,9) = 0.25*RR*TP
      P(3,9) = 0.25*RR*SP
      GO TO 2
   10 H(10)=0.25*RM*SS*TP
      P(1,10)=-0.25*SS*TP
      P(2,10)=-0.50*RM*S*TP
      P(3,10)= 0.25*RM*SS
      GO TO 2
   11 H(11)=0.25*RR*SM*TP
      P(1,11)=-0.50*R*SM*TP
      P(2,11)=-0.25*RR*TP
      P(3,11)= 0.25*RR*SM
      GO TO 2
   12 H(12)=0.25*RP*SS*TP
      P(1,12)= 0.25*SS*TP
      P(2,12)=-0.50*RP*S*TP
      P(3,12)= 0.25*RP*SS
      GO TO 2
   13 H(13)=0.25*RR*SP*TM
      P(1,13)=-0.50*R*SP*TM
      P(2,13)= 0.25*RR*TM
      P(3,13)=-0.25*RR*SP
      GO TO 2
   14 H(14)=0.25*RM*SS*TM
      P(1,14)=-0.25*SS*TM
      P(2,14)=-0.50*RM*S*TM
      P(3,14)=-0.25*RM*SS
      GO TO 2
   15 H(15)=0.25*RR*SM*TM
      P(1,15)=-0.50*R*SM*TM
      P(2,15)=-0.25*RR*TM
      P(3,15)=-0.25*RR*SM
      GO TO 2
   16 H(16)=0.25*RP*SS*TM
      P(1,16)= 0.25*SS*TM
      P(2,16)=-0.50*RP*S*TM
      P(3,16)=-0.25*RP*SS
      GO TO 2
   17 H(17)=0.25*RP*SP*TT
      P(1,17)= 0.25*SP*TT
      P(2,17)= 0.25*RP*TT
      P(3,17)=-0.50*RP*SP*T
      GO TO 2
   18 H(18)=0.25*RM*SP*TT
      P(1,18)=-0.25*SP*TT
      P(2,18)= 0.25*RM*TT
      P(3,18)=-0.50*RM*SP*T
      GO TO 2
   19 H(19)=0.25*RM*SM*TT
      P(1,19)=-0.25*SM*TT
      P(2,19)=-0.25*RM*TT
      P(3,19)=-0.50*RM*SM*T
      GO TO 2
   20 H(20)=0.25*RP*SM*TT
      P(1,20)= 0.25*SM*TT
      P(2,20)=-0.25*RP*TT
      P(3,20)=-0.50*RP*SM*T
      GO TO 2
   21 H(21)=RR*SS*TT
      P(1,21)=-2.0*R*SS*TT
      P(2,21)=-2.0*S*RR*TT
      P(3,21)=-2.0*T*RR*SS
      GO TO 2
C
C     MODIFY FIRST 8 FUNCTIONS IF 9 OR MORE NODES IN ELEMENT
C
   40 IH=0
   41 IH=IH + 1
      IF (IH.GT.NND9) GO TO 50
      II=IH + 7
      IF (II.EQ.IELX) GO TO 81
   42 IN=NOD9(IH)
      IF (IN.GT.16) GO TO 46
      I1=IN - 8
      I2=IPERM(I1)
      H(I1)=H(I1) - 0.5*H(IN)
      H(I2)=H(I2) - 0.5*H(IN)
      H(IH+8)=H(IN)
      DO 45 J=1,3
      P(J,I1)=P(J,I1) - 0.5*P(J,IN)
      P(J,I2)=P(J,I2) - 0.5*P(J,IN)
   45 P(J,IH+8)=P(J,IN)
      GO TO 41
   46 IF (IN.EQ.21) GO TO 30
      I1=IN - 16
      I2=I1 + 4
      H(I1)=H(I1) - 0.5*H(IN)
      H(I2)=H(I2) - 0.5*H(IN)
      H(IH+8)=H(IN)
      DO 47 J=1,3
      P(J,I1)=P(J,I1) - 0.5*P(J,IN)
      P(J,I2)=P(J,I2) - 0.5*P(J,IN)
   47 P(J,IH+8)=P(J,IN)
      GO TO 41
C
C     MODIFY FIRST 20 FUNCTIONS IF NODE 21 IS PRESENT
C
   30 IH=0
   31 IH=IH + 1
      IN=NOD9(IH)
      IF (IN.EQ.21) GO TO 35
      IF (IN.GT.16) GO TO 33
      I1=IN - 8
      I2=IPERM(I1)
      H(I1)=H(I1) + 0.125*H(21)
      H(I2)=H(I2) + 0.125*H(21)
      DO 32 J=1,3
      P(J,I1)=P(J,I1) + 0.125*P(J,21)
   32 P(J,I2)=P(J,I2) + 0.125*P(J,21)
      GO TO 31
   33 I1=IN - 16
      I2=I1 + 4
      H(I1)=H(I1) + 0.125*H(21)
      H(I2)=H(I2) + 0.125*H(21)
      DO 34 J=1,3
      P(J,I1)=P(J,I1) + 0.125*P(J,21)
   34 P(J,I2)=P(J,I2) + 0.125*P(J,21)
      GO TO 31
   35 DO 36 I=1,8
      H(I)=H(I) - 0.125*H(21)
      DO 36 J=1,3
   36 P(J,I)=P(J,I) - 0.125*P(J,21)
      NN=NND9 + 7
      IF (NN.EQ.8) GO TO 50
      DO 38 I=9,NN
      H(I)=H(I) - 0.25*H(21)
      DO 38 J=1,3
   38 P(J,I)=P(J,I) - 0.25*P(J,21)
      H(NND9+8)=H(21)
      DO 39 J=1,3
   39 P(J,NND9+8)=P(J,21)
C
C     MODIFY APPROPRIATE INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     FOR SPATIAL ISOTROPY FOR SPECIALLY DEGENERATED  20-NODE ELEMENTS
C
   50 IF (IDEGEN.LE.0) GO TO 80
      GO TO (80,60,70),ISOCOR
C
C     CORRECTIONS FOR PRISMS
C
   60 RSF=RR*SS*0.0625
      TPF=TP*0.125
      TMF=TM*0.125
      RSS=R*SS
      RRS=RR*S
      DHT=TP*RSF
      DHB=TM*RSF
      DHTR=-RSS*TPF
      DHTS=-RRS*TPF
      DHTT= RSF
      DHBR=-RSS*TMF
      DHBS=-RRS*TMF
      DHBT=-RSF
C
      H( 2)=H( 2) + DHT
      H( 3)=H( 3) + DHT
      H( 6)=H( 6) + DHB
      H( 7)=H( 7) + DHB
      H(10)=H(10) - DHT - DHT
      H(14)=H(14) - DHB - DHB
C
      P(1,2)=P(1,2) + DHTR
      P(2,2)=P(2,2) + DHTS
      P(3,2)=P(3,2) + DHTT
      P(1,3)=P(1,3) + DHTR
      P(2,3)=P(2,3) + DHTS
      P(3,3)=P(3,3) + DHTT
      P(1,6)=P(1,6) + DHBR
      P(2,6)=P(2,6) + DHBS
      P(3,6)=P(3,6) + DHBT
      P(1,7)=P(1,7) + DHBR
      P(2,7)=P(2,7) + DHBS
      P(3,7)=P(3,7) + DHBT
      P(1,10)=P(1,10) - DHTR - DHTR
      P(2,10)=P(2,10) - DHTS - DHTS
      P(3,10)=P(3,10) - DHTT - DHTT
      P(1,14)=P(1,14) - DHBR - DHBR
      P(2,14)=P(2,14) - DHBS - DHBS
      P(3,14)=P(3,14) - DHBT - DHBT
C
      GO TO 80
C
C     CORRECTIONS FOR TETRAHEDRA
C
   70 RSF=RR*SS*0.0625
      STF=SS*TT*0.0625
      RTF=RR*TT*0.0625
      RTT=R*TT*0.125
      RRT=RR*T*0.125
      DHB=RM*STF
      DHC=SP*RTF
      DHD=TM*RSF
      DHE=SM*RTF
      DHF=RR*STF*0.5
      DHBR=-STF
      DHCR=-SP*RTT
      DHDR=-R*SS*TM*0.125
      DHER=-SM*RTT
      DHFR=-R*STF
      DHBS=-RM*S*TT*0.125
      DHCS= RTF
      DHDS=-S*RR*TM*0.125
      DHES=-RTF
      DHFS=-S*RTF
      DHBT=-RM*SS*T*0.125
      DHCT=-SP*RRT
      DHDT=-RSF
      DHET=-SM*RRT
      DHFT=-T*RSF
      SBDF=DHB+DHD-DHF
      SBDFR=DHBR+DHDR-DHFR
      SBDFS=DHBS+DHDS-DHFS
      SBDFT=DHBT+DHDT-DHFT
C
      H( 5)=H( 5) + DHC + DHE
      H( 6)=H( 6) + DHC + SBDF
      H( 7)=H( 7) + DHE + SBDF
      H(13)=H(13) - DHC - DHC
      H(14)=H(14) - SBDF - SBDF
      H(15)=H(15) - DHE - DHE
C
      P(1,5)=P(1,5) + DHCR + DHER
      P(2,5)=P(2,5) + DHCS + DHES
      P(3,5)=P(3,5) + DHCT + DHET
      P(1,6)=P(1,6) + DHCR + SBDFR
      P(2,6)=P(2,6) + DHCS + SBDFS
      P(3,6)=P(3,6) + DHCT + SBDFT
      P(1,7)=P(1,7) + DHER + SBDFR
      P(2,7)=P(2,7) + DHES + SBDFS
      P(3,7)=P(3,7) + DHET + SBDFT
      P(1,13)=P(1,13) - DHCR - DHCR
      P(2,13)=P(2,13) - DHCS - DHCS
      P(3,13)=P(3,13) - DHCT - DHCT
      P(1,14)=P(1,14) - SBDFR - SBDFR
      P(2,14)=P(2,14) - SBDFS - SBDFS
      P(3,14)=P(3,14) - SBDFT - SBDFT
      P(1,15)=P(1,15) - DHER - DHER
      P(2,15)=P(2,15) - DHES - DHES
      P(3,15)=P(3,15) - DHET - DHET
C
C
C     EVALUATE JACOBIAN MATRIX AT POINT (R,S,T)
C
C
   80 IF (IELX.LT.IELD) RETURN
   81 IF (IINTP.GT.0) GO TO 110
      DO 100 I=1,3
      DO 100 J=1,3
      DUM=0.0
      DO 90 K=1,IELX
   90 DUM=DUM + P(I,K)*XX(J,K)
  100 XJ(I,J)=DUM
C
C
C     COMPUTE DETERMINANT OF JACOBIAN MATRIX AT POINT (R,S,T)
C
C
      DET = XJ(1,1)*XJ(2,2)*XJ(3,3)
     1    + XJ(1,2)*XJ(2,3)*XJ(3,1)
     2    + XJ(1,3)*XJ(2,1)*XJ(3,2)
     3    - XJ(1,3)*XJ(2,2)*XJ(3,1)
     4    - XJ(1,2)*XJ(2,1)*XJ(3,3)
     5    - XJ(1,1)*XJ(2,3)*XJ(3,2)
      IF (DET.GT.1.0D-08) GO TO 110
      WRITE (6,2000) NG,NEL
      STOP
  110 IF (IELX.LT.IELD) GO TO 42
C
C
      RETURN
C
C
 2000 FORMAT (////14H *** ERROR ***/18H ELEMENT GROUP NO.,I5/
     1        44H ZERO JACOBIAN DETERMINANT FOR 3/D ELEMENT (,I4,1H))
C
C
      END
C *CDC* *DECK STST3F
C *UNI* )FOR,IS N.STST3F, R.STST3F
      SUBROUTINE STST3F (DISD,PRESS,PROP)
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .     S U B R O U T I N E                                           .
C .                                                                   .
C .        TO CALCULATE PRESSURES FOR ALL FLUID MODELS                .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS
C
      DIMENSION DISD(1),DN(6),PROP(1)
C
      EQUIVALENCE (NPAR(3),INDNL), (NPAR(15),MODEL)
C
C
C     D E F I N I T I O N   O F   S T R A I N
C
C
C     LINEAR STRAIN TERMS
C
      STRAIN(1)=DISD(1)
      STRAIN(2)=DISD(2)
      STRAIN(3)=DISD(3)
      IF (INDNL.EQ.0) GO TO 80
C
C     NONLINEAR STRAIN TERMS
C
      DN(1)=0.5*(DISD(1)*DISD(1)+DISD(6)*DISD(6)+DISD(8)*DISD(8))
      DN(2)=0.5*(DISD(4)*DISD(4)+DISD(2)*DISD(2)+DISD(9)*DISD(9))
      DN(3)=0.5*(DISD(5)*DISD(5)+DISD(7)*DISD(7)+DISD(3)*DISD(3))
C
C     CALCULATE ALMANSI STRAINS (UPDATED LAGRANGIAN FORMULATION)
C
C
      DO 44 I=1,3
   44 STRAIN(I)=STRAIN(I)-DN(I)
C
C     C A L C U L A T E  P R E S S U R E S
C
C
   80 GO TO (1,1,1,1,1,1), MODEL
C
C
C.... MODEL = 1     C O N S T A N T  B U L K  M O D U L U S
C
    1 A1=PROP(1)
      STRESS(1)=A1*(STRAIN(1) + STRAIN(2) + STRAIN(3))
      PRESS=-STRESS(1)
      RETURN
C
C
      END
C *CDC* *DECK OVL170
C *CDC*      OVERLAY (ADINA,17,0)
C *CDC* *DECK LOAD
C *UNI* )FOR,IS  N.LOAD,  R.LOAD
C *CDC*      PROGRAM LOAD
      SUBROUTINE LOAD
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     OVERLAY TO CALCULATE THE LOAD VECTORS FOR SOLUTION
C
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      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
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /DISCON/ NDISCE,NIDM
      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 /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /SKEW/ NSKEWS
      COMMON /MDFRDM/ IDOF(6)
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /DPR/ ITWO
      COMMON /PRSHAP/ KSHAPE
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (A(1),IA(1))
      DIMENSION XTYPE(6)
      DATA XTYPE /8H  2-D   ,8H  3-D   ,8H  BEAM  ,8HISO/BEAM,8H PLATE
     1 ,8H SHELL  /
C
      IF (ISUB.GT.0) GO TO 500
C
      IF (IDATWR.GT.1) GO TO 15
C
      NLDT=NLOAD+NPR2+NPR3+NPBM+NP3DB+NPPL+NPSH+IDGRAV+NPDIS+NTEMP
      IF(NLDT.GT.0)GO TO 10
      GO TO 15
   10 WRITE (6,2050)
   15 CONTINUE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .-- N O T E S ---------                                             .
C .                                                                   .
C .   1. BLANK COMMON VARIABLE A IS ALWAYS DECLARED SINGLE PRECISION. .
C .   2. WHEN NSTE.EQ.0, LOAD VECTORS ARE NOT WRITTEN ONTO TAPE.      .
C .   3. WHEN MODEX.EQ.0, LOAD VECTORS ARE NOT CALCULATED             .
C .      (REGARDLESS OF THE VALUE OF NSTE).                           .
C .   4. EVEN WHEN MODEX.EQ.0, TEMPERATURE TAPE IS CREATED,           .
C .      PROVIDED ITP96.EQ.2.                                         .
C .                                                                   .
C .                                                                   .
C .-- S T O R A G E -----                                             .
C .                                                                   .
C .   ADDRESS      VARIABLE       LENGTH                              .
C .                                                                   .
C .      M1        ID             NDOF*NUMNP (NSTE.GT.0 ONLY)         .
C .      M1A       NODSYS         NUMNP (IF NSKEWS.GT.0 ONLY)         .
C .      M2        RG             NTFN*NSTE*ITWO                      .
C .      M3        RGST           NTFN                                .
C .      M4        R              (NUMNP OR NEQ)*ITWO                 .
C .      M5        TIMES          NTFN*NPTM*ITWO                      .
C .      M6        RV             NTFN*NPTM*ITWO                      .
C .      M7        IPNT           NTFN                                .
C .                                                                   .
C .      M8        X              NUMNP*ITWO                          .
C .      M9        Y              NUMNP*ITWO                          .
C .      M10       Z              NUMNP*ITWO                          .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      TEND=(NSTE-1)*DT + DTA
      M1=N2
      M1A=M1
      IF (NSTE.GT.0) M1A=M1 + NDOF*NUMNP
      M2=M1A
      IF (NSKEWS.NE.0) M2=M1A + NUMNP
      M3=M2 + NTFN*NSTE*ITWO
      M4=M3 + NTFN*ITWO
C
      MLONG=NEQ
      IF (NTEMP.EQ.0) GO TO 20
      IF (NUMNP.GT.NEQ) MLONG=NUMNP
   20 IF (NTFN.GT.MLONG) MLONG=NTFN
      M5=M4 + MLONG*ITWO
C
      M6=M5 + NTFN*NPTM*ITWO
      M7=M6 + NTFN*NPTM*ITWO
      M8=M7 + NTFN
      M9=M8 + NUMNP*ITWO
      M10=M9 + NUMNP*ITWO
      M11=M10 + NUMNP*ITWO
      NLDT=NPR2+NPR3+NPBM+NP3DB+NPPL+NPSH
      IF(NLDT.EQ.0) M11=M8
C
C * * * * * * * * * * * * * * * * * * * * * * * * *
C *   C O N C E N T R A T E D   L O A D I N G     *
C * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   STORAGE FOR CONCENTRATED LOADING                                .
C .                                                                   .
C .      M103      NODE           NLOAD                               .
C .      M104      IDIRN          NLOAD                               .
C .      M105      NCUR           NLOAD                               .
C .      M106      FACTOR         NLOAD*ITWO                          .
C .      M107      ARTIME         NLOAD*ITWO                          .
C .      M108      KL             NLOAD                               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      M103=M11
      M104=M103 + NLOAD
      M105=M104 + NLOAD
      M106=M105 + NLOAD
      M107=M106 + NLOAD*ITWO
      M108=M107 + NLOAD*ITWO
      M109=M108 + NLOAD
      MFINAL=M109 - 1
C
      IF(ISTPRT.GT.0) WRITE(6,2000)
      CALL SIZE (MFINAL)
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .      1.READ ID ARRAY INTO CORE                .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
      REWIND 3
      REWIND 12
      IF (NSTE.EQ.0) GO TO 30
      MEND=M1A - 1
      REWIND 8
      READ (8) (IA(I),I=M1,MEND)
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .      2.READ TIME FUNCTIONS                    .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
   30 IF (NTFN.EQ.0) GO TO 40
      CALL TFUNCT (A(M2),A(M3),A(M5),A(M6),A(M7),NTFN,NPTM)
C
   40 NT=3
      NLDT=NPR2+NPR3+NPBM+NP3DB+NPPL+NPSH
      IF(NLDT.NE.0)GO TO 42
      IF (NSKEWS.EQ.0) GO TO 45
      DO 41 I=1,3
   41 READ (NT)
      GO TO 43
C
C     READ XYZ COORDINATE VECTORS INTO CORE
C
   42 NN=M9 - 1
      READ (NT) (A(I),I=M8,NN)
      NN=M10 - 1
      READ (NT) (A(I),I=M9,NN)
      NN=M11 - 1
      READ (NT) (A(I),I=M10,NN)
   43 NN=M2 - 1
      IF (NSKEWS.GT.0) READ (NT) (IA(I),I=M1A,NN)
      REWIND NT
C
   45 NW=1
      IF (NPR2.GT.0) NW=NW + 1
      IF (NPR3.GT.0) NW=NW + 1
      IF (NPBM.GT.0) NW=NW + 1
      IF (NP3DB.GT.0) NW=NW + 1
      IF (NPPL.GT.0) NW=NW + 1
      IF (NPSH .GT.0) NW=NW + 1
      IF ( IDGRAV.GT.0) NW=NW + 1
      NWLOAD=3
      NRLOAD=12
      II=NW - (NW/2)*2
      IF (II.NE.0) GO TO 50
      NWLOAD=12
      NRLOAD=3
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .      4.READ CONCENTRATED LOADS                .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
   50 CALL CLOADS (A(M1),A(M2),A(M3),A(M4),A(M103),A(M104),
     1             A(M105),A(M106),A(M107),A(M108),A(N01),A(N02),A(N03),
     2             IDOF,NTFN,NDOF,NEQ,NIDM,NWLOAD)
C
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * *
C *   R E A D   P R E S S U R E   L O A D I N G   *
C * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      IDUMMY=0
  100 IDUMMY=IDUMMY + 1
      GO TO (210,215,125,220,225,230,200), IDUMMY
C
C
C     CALL SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT
C     LOADING DUE TO 2/D PRESSURE LOADING
C
  210 IF (NPR2.EQ.0) GO TO 100
      NODE2=3
      NDFR2=6
C
      M101=M11
      M102=M101 + NDFR2*NPR2*ITWO
      M103=M102 + NDFR2*NPR2
      M104=M103 + NPR2*ITWO
      M105=M104 + NPR2
      M106=M105 + 2*NPR2*ITWO
      M107=M106 + 3*NPR2
      M108=M107 + NPR2*ITWO
      M109=M108 + NPR2
      M110=M109 + NPR2
      M111=M110 + NPR2
      MFINAL=M111-1
C
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE (MFINAL)
C
      CALL TODPRL (A(M1),A(M2),A(M3),A(M4),A(M8),A(M9),A(M10),
     1             A(M101),A(M102),A(M103),A(M104),A(M105),
     1             A(M106),A(M107),A(M108),A(M109),A(M110),A(N01),
     2             A(N02),A(N03),A(N06),A(M1A),NODE2,NDFR2,NDOF,NTFN,
     3             NEQ,NIDM,IDOF,NSKEWS,NRLOAD,NWLOAD,NUMNP)
C
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 100
C
C     CALL SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT
C     FORCES DUE TO PRESSURE LOADING
C     A)          FOR 3-D ELEMENTS
C     B)          FOR ISO/BEAM
C     C)          FOR PLATE
C     D)          FOR SHELLS
C
  215 IF (NPR3.LE.0) GO TO 100
      NPR=NPR3
      NODEP=8
      NDFRP=24
  106 CONTINUE
      M101=M11
      M102=M101 + NDFRP*NPR*ITWO
      M103=M102 + NDFRP*NPR
      M104=M103 + NPR*ITWO
      M105=M104 + NPR
      M106=M105 + 4*NPR*ITWO
      M107=M106 + NODEP*NPR
      M108=M107 + NPR
      M109=M108 + NPR
      NFACE=0
      IF (NODEP.EQ.5) NFACE=1
      M110 = M109 + NFACE*NPR
      M111=M110 + KSHAPE*NPR
      MFINAL = M111 - 1
C
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE(MFINAL)
C
      CALL THDPRL(A(M1),A(M2),A(M3),A(M4),A(M8),A(M9),A(M10),
     1            A(M101),A(M102),A(M103),A(M104),A(M105),A(M106),
     2            A(M107),A(M108),A(M109),A(M110),
     3            A(N01),A(N02),A(N03),A(N06),A(M1A),
     4            NPR,NODEP,NDFRP,NDOF,NTFN,NEQ,NIDM,IDOF,NSKEWS,
     5            NRLOAD,NWLOAD,NUMNP)
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 100
C
C
  220 IF (NP3DB.LE.0) GO TO 100
      NPR=NP3DB
C
C     NUMBER OF NODES FOR A 3-D BEAM=4
C     NODEP=5 TO ACCOMODATE FOR THE AUXILLIARY NODE
C
C     NFACE.EQ.1 FOR ISO/BEAM FOR STORING INFORMATION OF THE
C                FACE ON WHICH LOAD IS APPLIED
C
      NODEP=5
      NDFRP=12
      GO TO 106
C
  225 IF (NPPL.LE.0) GO TO 100
      NPR=NPPL
      NODEP=3
      NDFRP=9
      GO TO 106
C
  230 IF (NPSH.LE.0) GO TO 200
      NPR=NPSH
      NODEP=16
      NDFRP=48
      GO TO 106
C
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * * *
C * B E A M  D I S T R I B U T E D  L O A D I N G   *
C * * * * * * * * * * * * * * * * * * * * * * * * * *
C
  125 IF (NPBM.EQ.0) GO TO 100
      M101=M11
      M102=M101 + 12*NPBM*ITWO
      M103=M102 + 12*NPBM
      M104=M103 + NPBM*ITWO
      M105=M104 + NPBM
      M106=M105 + 2*NPBM*ITWO
      M107=M106 + 3*NPBM
      M108=M107 + NPBM
      M109=M108 + NPBM
      M110=M109 + NPBM
      MFINAL=M110-1
C
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE (MFINAL)
      CALL BMLOAD (A(M1),A(M2),A(M3),A(M4),A(M8),A(M9),A(M10),
     1             A(M101),A(M102),A(M103),A(M104),A(M105),A(M106),
     2             A(M107),A(M108),A(N01),A(N02),A(N03),A(N06),
     3             A(M1A),A(M109),IDOF,NDOF,NTFN,NEQ,NIDM,
     4             NSKEWS,NRLOAD,NWLOAD,NUMNP)
C
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 100
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C *   M A S S   P R O P O R T I O N A L   L O A D I N G   *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
  200 IF (IDGRAV.EQ.0) GO TO 250
      M101=M8
      M102=M8 + NEQ*ITWO
      CALL GRAVL (A(M1),A(M2),A(M4),A(M101),A(N06),A(M1A),
     1            NEQ,NDOF,NTFN,MODEX,NRLOAD,NWLOAD,NUMNP,IDOF)
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C *   P R E S C R I B E D   D I S P L A C E M E N T S   D A T A   *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
  250 IF (NPDIS.EQ.0) GO TO 290
      NTAPE=13
      M101=M8 + NPDIS
      M102=M101 + NPDIS
      M103=M102 + NPDIS
      M104=M103 + NPDIS*ITWO
      M105=M104 + NPDIS*ITWO
      M106=M105 + NPDIS
      MFINAL=M106 - 1
C
      IF(ISTPRT.GT.0) WRITE(6,2025)
      CALL SIZE (MFINAL)
C
      CALL PDISP (A(M1),A(M2),A(M3),A(M4),A(M8),A(M101),A(M102),
     1            A(M103),A(M104),A(M105),A(N04),NTFN,NDOF,NPDIS,NTAPE)
C
C * * * * * * * * * * * * * * * * * * * * * * * * *
C *   R E A D   T E M P E R A T U R E   D A T A   *
C *   A N D   C R E A T E   T A P E               *
C * * * * * * * * * * * * * * * * * * * * * * * * *
C
  290 IF (ITP96.NE.2) GO TO 300
C
      M101=M8
      M102=M101 + NTEMP
      M103=M102 + NTEMP
      M104=M103 + NTEMP*ITWO
      M105=M104 + NTEMP*ITWO
      M106=M105 + NTEMP
      MFINAL=M106-1
C
      IF(ISTPRT.GT.0) WRITE(6,2030)
      CALL SIZE (MFINAL)
C
      CALL TLOADS (A(M4),A(M5),A(M6),A(M7),A(M101),A(M102),A(M103),
     1             A(M104),A(M105),NPTM)
C
C
  300 GO TO 599
C
C
C     S U B S T R U C T U R E   L O A D   C A L C U L A T I O N
C
C
  500 CALL SLOAD
C
C
  599 CONTINUE
C
C
      RETURN
 2000 FORMAT (////44H **STORAGE CHECK FOR CONCENTRATED LOAD INPUT)
 2020 FORMAT(////,21H **STORAGE CHECK FOR ,A8,29H ELEMENT PRESSURE LOAD
     1INPUT  )
 2025 FORMAT (////40H **STORAGE CHECK FOR DISPLACEMENTS INPUT  )
 2030 FORMAT (////44H **STORAGE CHECK FOR NODAL TEMPERATURE INPUT)
C
 2050 FORMAT (1H1,37H A P P L I E D   L O A D S   D A T A  )
C
      END
C *CDC* *DECK SLOAD
C *UNI* )FOR,IS  N.SLOAD,  R.SLOAD
      SUBROUTINE SLOAD
C
C     PROGRAM TO CALCULATE SUBSTRUCTURE LOAD VECTORS
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      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 /TIMFN/ TEND,NTFN,NPTM
      COMMON /SLOA/ N09C,ITMFN,ICOORD,NUSE
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /SKEW/ NSKEWS
      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 /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /DPR/ ITWO
      COMMON /PRSHAP/ KSHAPE
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (A(1),IA(1))
      DIMENSION XTYPE(6)
      DATA XTYPE /8H  2-D   ,8H  3-D   ,8H  BEAM  ,8HISO/BEAM,8H PLATE
     1 ,8H SHELL  /
C
C
      IF (IDATWR.GT.1) GO TO 15
      NLDT=NLOAD+NPR2+NPR3+NPBM+NP3DB+NPPL+NPSH
   10 WRITE (6,2050)
      WRITE (6,2100) NSUB,NUSE
      IF (NLDT.EQ.0) WRITE (6,2111)
   15 CONTINUE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .-- S T O R A G E -----                                             .
C .                                                                   .
C .   ADDRESS      VARIABLE       LENGTH                              .
C .                                                                   .
C .      M1        RG             NTFN*NSTE*ITWO                      .
C .      M2        RGST           NTFN                                .
C .      M3        TIMES          NTFN*NPTM*ITWO                      .
C .      M4        RV             NTFN*NPTM*ITWO                      .
C .      M5        IPNT           NTFN                                .
C .                                                                   .
C .      M6        R              NUMNPS*ITWO                         .
C .      M7        ID             NDOFS*NUMNPS                        .
C .      M8        X              NUMNPS*ITWO                         .
C .      M9        Y              NUMNPS*ITWO                         .
C .      M10       Z              NUMNPS*ITWO                         .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      TEND=(NSTE-1)*DT + DTA
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .        READ TIME FUNCTIONS                    .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
      M1=N09C
      M2=M1 + NTFN*NSTE*ITWO
      M3=M2 + NTFN*ITWO
      M4=M3 + NTFN*NPTM*ITWO
      M5=M4 + NTFN*NPTM*ITWO
      IF (ITMFN.GT.0) GO TO 100
C
      IF (NTFN.EQ.0) GO TO 100
      CALL TFUNCT (A(M1),A(M2),A(M3),A(M4),A(M5),NTFN,NPTM)
      ITMFN=1
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   READ ID ARRAY AND NODAL COORDINATES INTO CORE   .               .
C . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
  100 M6=N2
      M7=M6 + NEQS*ITWO
      M7A=M7 + NDOFS*NUMNPS
      M8=M7A
      IF (NSKEWS.GT.0) M8=M7A + NUMNPS
      M9=M8 + NUMNPS*ITWO
      M10=M9 + NUMNPS*ITWO
      M11=M10 + NUMNPS*ITWO
      IF (ICOORD.EQ.0) GO TO 150
      DO 120 I=1,4
  120 BACKSPACE 15
  150 ICOORD=1
C
      NT=15
      MEND=M8 - 1
      READ (NT) (IA(I),I=M7,MEND)
C
      NN=M9 - 1
      READ (NT) (A(I),I=M8,NN)
      NN=M10 - 1
      READ (NT) (A(I),I=M9,NN)
      NN=M11 - 1
      READ (NT) (A(I),I=M10,NN)
C
C * * * * * * * * * * * * * * * * * * * * * * * * *
C *   C O N C E N T R A T E D   L O A D I N G     *
C * * * * * * * * * * * * * * * * * * * * * * * * *
C
      M103=M11
      M104=M103 + NLOAD
      M105=M104 + NLOAD
      M106=M105 + NLOAD
      M107=M106 + NLOAD*ITWO
      M108=M107 + NLOAD*ITWO
      M109=M108 + NLOAD
      MFINAL=M109 - 1
C
      IF(ISTPRT.GT.0) WRITE(6,2000)
      CALL SIZE (MFINAL)
C
      REWIND 3
      REWIND 12
      NW=1
      IF (NPR2.GT.0) NW=NW + 1
      IF (NPR3.GT.0) NW=NW + 1
      IF(NPBM.GT.0) NW=NW + 1
      IF(NP3DB.GT.0) NW=NW + 1
      IF(NPPL.GT.0) NW=NW + 1
      IF(NPSH.GT.0) NW=NW + 1
      NWLOAD=3
      NRLOAD=12
      II=NW - (NW/2)*2
      IF (II.NE.0) GO TO 50
      NWLOAD=12
      NRLOAD=3
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .        READ CONCENTRATED LOADS                .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
   50 CALL CLOADS (A(M7),A(M1),A(M2),A(M6),A(M103),A(M104),
     1             A(M105),A(M106),A(M107),A(M108),A(N01),A(N02),A(N03),
     2             IDOFS,NTFN,NDOFS,NEQS,NIDM,NWLOAD)
C
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * *
C *   R E A D   P R E S S U R E   L O A D I N G   *
C * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     CALL SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT
C     LOADING DUE TO 2/D PRESSURE LOADING
C
      IDUMMY=0
  300 IDUMMY=IDUMMY + 1
      GO TO (310,315,400,320,325,330,850), IDUMMY
C
  310 IF (NPR2.EQ.0) GO TO 300
      NODE2=3
      NDFR2=6
C
      M101=M11
      M102=M101 + NDFR2*NPR2*ITWO
      M103=M102 + NDFR2*NPR2
      M104=M103 + NPR2*ITWO
      M105=M104 + NPR2
      M106=M105 + 2*NPR2*ITWO
      M107=M106 + 3*NPR2
      M108=M107 + NPR2*ITWO
      M109=M108 + NPR2
      M110=M109 + NPR2
      M111=M110 + NPR2
      MFINAL=M111-1
C
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE (MFINAL)
C
      CALL TODPRL (A(M7),A(M1),A(M2),A(M6),A(M8),A(M9),A(M10),
     1             A(M101),A(M102),A(M103),A(M104),A(M105),
     1             A(M106),A(M107),A(M108),A(M109),A(M110),A(N01),
     2             A(N02),A(N03),A(N06),A(M7A),NODE2,NDFR2,NDOFS,NTFN,
     3             NEQS,NIDM,IDOFS,NSKEWS,NRLOAD,NWLOAD,NUMNPS)
C
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 300
C
C     FORCES DUE TO PRESSURE LOADING
C     A)          3-D ELEMENTS
C     B)          ISO/BEAM ELEMENTS
C     C)          FOR PLATE
C     D)          FOR SHELLS
C
  315 IF (NPR3.LE.0) GO TO 300
      NPR=NPR3
      NODEP=8
      NDFRP=24
  106 CONTINUE
      M101=M11
      M102=M101 + NDFRP*NPR*ITWO
      M103=M102 + NDFRP*NPR
      M104=M103 + NPR*ITWO
      M105=M104 + NPR
      M106=M105 + 4*NPR*ITWO
      M107=M106 + NODEP*NPR
      M108=M107 + NPR
      M109=M108 + NPR
      NFACE=0
      IF (NODEP.EQ.5) NFACE=1
      M110 = M109 + NFACE*NPR
      M111=M110 + KSHAPE*NPR
      MFINAL=M111-1
C
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE(MFINAL)
C
      CALL THDPRL(A(M7),A(M1),A(M2),A(M6),A(M8),A(M9),A(M10),
     1            A(M101),A(M102),A(M103),A(M104),A(M105),A(M106),
     2            A(M107),A(M108),A(M109),A(M110),
     3            A(N01),A(N02),A(N03),A(N06),A(M7A),
     4            NPR,NODEP,NDFRP,NDOFS,NTFN,NEQS,NIDM,IDOFS,NSKEWS,
     5            NRLOAD,NWLOAD,NUMNPS)
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 300
C
  320 IF (NP3DB.LE.0) GO TO 300
      NPR=NP3DB
C
C     NUMBER OF NODES FOR A 3-D BEAM=4
C     NODEP=5 TO ACCOMODATE FOR THE AUXILLIARY NODE
C
      NODEP=5
      NDFRP=12
      GO TO 106
  325 IF (NPPL.LE.0) GO TO 300
      NPR=NPPL
      NODEP=3
      NDFRP=9
      GO TO 106
C
  330 IF (NPSH.LE.0) RETURN
      NPR=NPSH
      NODEP=16
      NDFRP=48
      GO TO 106
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * * *
C * B E A M  D I S T R I B U T E D  L O A D I N G  *
C * * * * * * * * * * * * * * * * * * * * * * * * * *
C
  400 IF (NPBM.EQ.0) GO TO 300
      M101=M11
      M102=M101 + 12*NPBM*ITWO
      M103=M102 + 12*NPBM
      M104=M103 + NPBM*ITWO
      M105=M104 + NPBM
      M106=M105 + 2*NPBM*ITWO
      M107=M106 + 3*NPBM
      M108=M107 + NPBM
      M109=M108 + NPBM
      M110=M109 + NPBM
      MFINAL=M110-1
      IF (ISTPRT.GT.0) WRITE(6,2020) XTYPE(IDUMMY)
      CALL SIZE (MFINAL)
      CALL BMLOAD (A(M7),A(M1),A(M2),A(M6),A(M8),A(M9),A(M10),
     1             A(M101),A(M102),A(M103),A(M104),A(M105),A(M106),
     2             A(M107),A(M108),A(N01),A(N02),A(N03),A(N06),
     3             A(M7A),A(M109),IDOFS,NDOFS,NTFN,NEQS,NIDM,
     4             NSKEWS,NRLOAD,NWLOAD,NUMNPS)
      NSAVE=NRLOAD
      NRLOAD=NWLOAD
      NWLOAD=NSAVE
      GO TO 300
C
  850 RETURN
C
 2000 FORMAT (////44H **STORAGE CHECK FOR CONCENTRATED LOAD INPUT)
 2020 FORMAT(////,21H **STORAGE CHECK FOR ,A8,29H ELEMENT PRESSURE LOAD
     1INPUT  )
C
 2050 FORMAT (1H1,62H S U B S T R U C T U R E   A P P L I E D   L O A D
     1S   D A T A    )
 2100 FORMAT (//22H SUBSTRUCTURE NUMBER =,I3,24H IDENTIFICATION SET NO =
     1  I3)
 2111 FORMAT (//40H NO LOADS APPLIED FOR THIS SUBSTRUCTURE  //)
C
      END
C *CDC* *DECK CLOADS
C *UNI* )FOR,IS N.CLOADS,R.CLOADS
      SUBROUTINE CLOADS (ID,RG,RGST,R,NOD,IDIRN,NCUR,FAC,ARTM,KL,
     1                   NID,IDI,BETA,IDOF,NTFND,NDOF,NEQ,NIDM,NWLOAD)
C
C     SUBROUTINE
C     3. TO READ CONCENTRATED NODAL LOADS
C     4. TO CALCULATE THE LOAD VECTORS CORRESPONDING
C        TO THE CONCENTRATED LOADS
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C     V A R I A B L E S :
C
C
C     ID      = ARRAY OF BOUNDARY CONDITION CODES
C     RG      = INTERPOLATED VALUES OF TIME FUNCTIONS
C     R       = LOAD VECTOR
C     TIMV,RV = ABSCISSA AND ORDINATES OF TIME FUNCTIONS
C     NOD     = NODAL POINTS TO WHICH LOADS ARE APPLIED
C     NCUR    = TIME FUNCTION NUMBERS OF LOADS
C     IDIRN   = DIRECTION CODES OF LOADS
C     FAC     = MULTIPLIER OF LOADS
C     ARTM    = ARRIVAL TIMES OF LOADS
C     KL      = INCREMENTS IN NODES FOR GENERATION
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NNN,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      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 /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SKEW/ NSKEWS
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
C
      DIMENSION ID(NDOF,1),RG(NTFND,1),RGST(1),R(NEQ),NOD(1),IDIRN(1),
     1          NCUR(1),FAC(1),ARTM(1),KL(1),NID(1),IDI(NIDM,1),
     2          BETA(NIDM,1)
      INTEGER IDOF(6)
C
      IF (NLOAD.EQ.0) GO TO 120
C
      IF (IDATWR.GT.1) GO TO 110
      IF (NSKEWS.LE.0) WRITE (6,2000)
      IF (NSKEWS.GT.0) WRITE (6,2100)
  110 CONTINUE
C
      READ (5,1000) (NOD(I),IDIRN(I),NCUR(I),FAC(I),ARTM(I),KL(I),
     1             IDEBUG,I=1,NLOAD)
      ISTOP=0
      DO 125 I=1,NLOAD
      IF (NCUR(I).GE.1 .AND. NCUR(I).LE.NTFN) GO TO 125
      ISTOP=ISTOP + 1
      WRITE (6,3000) NOD(I),IDIRN(I),NCUR(I)
  125 CONTINUE
      IF (ISTOP.EQ.0) GO TO 130
      STOP
  130 KL(NLOAD)=0
C
      IF (IDATWR.GT.1) GO TO 120
      DO 140 I=1,NLOAD
  140 WRITE (6,2010) NOD(I),IDIRN(I),NCUR(I),FAC(I),ARTM(I),KL(I)
C
  120 IF (NSTE.EQ.0)     RETURN
      IF (MODEX.EQ.0)    RETURN
C
      DO 200 K=1,NSTE
C
      DO 210 I=1,NEQ
  210 R(I)=0.
C
      IF (NLOAD.EQ.0) GO TO 260
C
      DO 220 L=1,NLOAD
      LI=IDIRN(L)
      IF (IDOF(LI).EQ.1) GO TO 220
      LDOF=LI
      LN=NOD(L)
      ARTMT=ARTM(L)
      FACT=FAC(L)
      LC=NCUR(L)
      IF (KL(L).EQ.0) GO TO 222
      DARTM=(ARTM(L+1) - ARTM(L))/((NOD(L+1) - NOD(L))/KL(L))
      FINCR=(FAC(L+1) - FAC(L))/((NOD(L+1) - NOD(L))/KL(L))
  222 DO 230 I=1,LDOF
  230 IF (IDOF(I).EQ.1) LI=LI - 1
  224 NSTEA=ARTMT/DT
      NSTEF=K - NSTEA
      IF (NSTEF.LE.0) GO TO 226
      AFACT=NSTEA - ARTMT/DT + 1.
C
      II=ID(LI,LN)
      RGFR=RG(LC,NSTEF)
      IF (ARTMT.EQ.0.) GO TO 240
C
      RGFR=RGST(LC)*(1.0 - AFACT) + RGFR*AFACT
      IF (NSTEF.LE.1) GO TO 240
      RGFR=RG(LC,NSTEF-1)*(1.0 - AFACT) + RG(LC,NSTEF)*AFACT
  240 IF (II) 245,226,255
C
C     TRANSFER LOADS APPLIED AT CONSTRAINED DOF
C
  245 NCE=-II
      ND=NID(NCE)
      DO 250 I=1,ND
      II=IDI(I,NCE)
      FRAC=BETA(I,NCE)
  250 R(II)=R(II) + RGFR*FACT*FRAC
      GO TO 226
C
  255 R(II)=R(II) + RGFR*FACT
C
  226 IF (KL(L).EQ.0) GO TO 220
      LN=LN + KL(L)
      IF (LN.GE.NOD(L+1)) GO TO 220
      FACT=FACT + FINCR
      ARTMT=ARTMT + DARTM
      GO TO 224
  220 CONTINUE
C
  260 WRITE (NWLOAD) R
      IF (IDEBUG.EQ.5) WRITE (6,6000) (R(I),I=1,NEQ)
  200 CONTINUE
C
      RETURN
 1000 FORMAT (3I5,2F10.0,I5,5X,I5)
 2000 FORMAT (////46H C O N C E N T R A T E D   L O A D S   D A T A//4X,
     1        53H NODE   DIRECTION   LOAD CURVE   LOAD CURVE MULTIPL   ,
     2        50H   ARRIVAL TIME   NODE GENERATION                    )
 2100 FORMAT (////46H C O N C E N T R A T E D   L O A D S   D A T A///
     1        35H CONCENTRATED LOADS ARE ASSUMED    /
     2 56H TO BE GIVEN IN THE SKEW COORDINATE SYSTEM OF EACH NODE.///4X,
     3 53H NODE   DIRECTION   LOAD CURVE   LOAD CURVE MULTIPL  ,
     4 34H    ARRIVAL TIME   NODE GENERATION)
 2010 FORMAT (1H0,2X,I5,5X,I4,9X,I4,9X,E13.5,8X,E12.4,7X,I5)
 3000 FORMAT (///47H TIME FUNCTION NUMBER SPECIFIED IS OUT-OF-RANGE,/
     1        5H NOD=,I5,7H IDIRN=,I5,6H NCUR=,I5)
 6000 FORMAT (10F12.5/)
      END
C *CDC* *DECK TODPRL
C *UNI* )FOR,IS N.TODPRL,R.TODPRL
      SUBROUTINE TODPRL (ID,RG,RGST,R,X,Y,Z,PR,IDOFR,ARTM,NCUR,
     1             PRINT,NODPR,THICV,IELTYP,KL,IDIRN,NID,IDI,BETA,
     2             RSDCOS,NODSYS,NODE2,NDFR2,NDOF,NTFND,NEQ,NIDM,
     3             IDOF,NSKEWS,NRLOAD,NWLOAD,NUMNPP)
C
C     SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT LOADS
C     DUE TO PRESSURE ON 2/D ELEMENT FACE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C     V A R I A B L E S :
C
C
C     NODPR = NODES TO WHICH PRESSURE LOADING IS APPLIED
C     PRINT = PRESSURE INTENSITIES AT NODAL POINTS
C     PR    = WORK EQUIVALENT NODAL POINT PRESSURE LOADS
C     IDOFR = DEGREES OF FREEDOM INTO WHICH LOADS IN PR
C             HAVE TO BE ADDED
C     NPR2  = NUMBER OF PRESSURE LOAD SETS
C     NODE2 = NUMBER OF NODES PER PRESSURE SET (CURRENTLY 3)
C     NDFR2 = NODE2*2
C     RG    = INTERPOLATED VALUES OF TIME FUNCTIONS
C     ARTM  = ARRIVAL TIMES OF PRESSURE LOADS
C     NCUR  = TIME FUNCTIONS CORRESPONDING TO PRESSURE LOADS
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      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 /TIMFN/ TEND,NTFN,NPTM
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      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
      DIMENSION ID(NDOF,1),RG(NTFND,1),NODPR(NODE2,1),PRINT(2,1),
     1          IDOFR(NDFR2,1),NCUR(1),R(NEQ),ARTM(1),X(1),Y(1),Z(1),
     2          PR(NDFR2,1),THICV(1),IELTYP(1),Y2(3),Z2(3),WGTL(3),
     3          XGL(3),VEC(6),RGST(1),PRINTM(2),NODPRM(4),KL(1)
      DIMENSION IDIRN(1),NID(1),IDI(NIDM,1),BETA(NIDM,1),RSDCOS(1),
     1          NODSYS(1),IDOF(6)
C
C
      DATA XGL/
     1 -.7745966692415D0, .0000000000000D0, .7745966692415D0/
      DATA WGTL/
     1  .5555555555556D0, .8888888888889D0, .5555555555556D0/
C
C
      IF (IDATWR.LE.1) WRITE(6,2000)
C
C
C     R E A D   A N D   G E N E R A T E    2 / D   P R E S S U R E
C     L O A D    I N F O R M A T I O N
C
C
      L=1
      K=1
   10 READ(5,1000) IELTYM,NCURM,IDIRNM,(PRINTM(I),I=1,2),
     1             THICVM,ARTMM,KLM,IDEBUG,
     1             (NODPRM(I),I=1,NODE2)
C
      IF (K.NE.L) GO TO 50
C
C     SAVE LOAD INFORMATION
C
   20 IF (IELTYM.EQ.1 .OR. THICVM.LT.1.0D-8) THICVM=1.0
      IELTYP(K)=IELTYM
      THICV(K)=THICVM
      NCUR(K)=NCURM
      DO 35 I=1,NODE2
   35 NODPR(I,K)=NODPRM(I)
      DO 36 I=1,2
   36 PRINT(I,K)=PRINTM(I)
      KL(K)=KLM
      ARTM(K)=ARTMM
      IDIRN(K)=IDIRNM
C
      IF (KLM.EQ.0) GO TO 90
      IF (L.EQ.NPR2) GO TO 99
C
      L=L + 1
      GO TO 10
C
C     GENERATE PRESSURE LOAD INFORMATION
C
   50 KK=K
      NGNOD=(NODPRM(1) - NODPR(1,KK))/KL(KK)
      DARTM=(ARTMM - ARTM(KK))/NGNOD
      DPR=(PRINTM(1) - PRINT(1,KK))/NGNOD
      DP1=PRINTM(1) - PRINT(1,KK)
      DP2=PRINTM(2) - PRINT(2,KK)
      DP=DP1 - DP2
      IF (DP.GT.0.0001) WRITE(6,3000)
C
      NJ=NGNOD - 1
      DO 52 J=1,NJ
      K=K + 1
      IELTYP(K)=IELTYP(KK)
      THICV(K)=THICV(KK)
      NCUR(K)=NCUR(KK)
C
      KL(K)=KL(KK)
      IDIRN(K)=IDIRN(KK)
      DO 53 I=1,NODE2
      NODPR(I,K)=NODPR(I,K-1) + KL(KK)
      IF (NODPR(I,KK).EQ.0) NODPR(I,K)=0
   53 CONTINUE
      DO 54 I=1,2
   54 PRINT(I,K)=PRINT(I,K-1) + DPR
      ARTM(K)=ARTM(K-1) + DARTM
   52 CONTINUE
C
      IF (K.LE.NPR2) GO TO 55
      WRITE(6,3010)
      STOP
   55 K=K + 1
      L=K
      IF (L.LE.NPR2) GO TO 20
      GO TO 99
C
C
   90 L=L + 1
      K=L
      IF (L.LE.NPR2) GO TO 10
C
   99 CONTINUE
C
C     WRITE 2/D PRESSURE LOAD INFORMATION
C
      DO 100 K=1,NPR2
      IF (IDATWR.LE.1)
     1WRITE (6,2005) IELTYP(K),NCUR(K),(NODPR(I,K),I=1,NODE2),
     2               (PRINT(I,K),I=1,2),THICV(K),ARTM(K),KL(K),IDIRN(K)
C
C     ERROR TESTS
C
      DO 110 I=1,NODE2
      IF (NODPR(I,K).LE.NUMNPP) GO TO 110
      WRITE(6,2010) K,NODPR(I,K)
      STOP
  110 CONTINUE
C
      IF (NCUR(K).GE.1 .AND. NCUR(K).LE.NTFN) GO TO 120
      WRITE(6,2020) K,NCUR(K)
      STOP
C
  120 IF (ARTM(K).GE.0. .AND. ARTM(K).LE.TEND) GO TO 100
      WRITE (6,2030) K
C
  100 CONTINUE
      IF (MODEX.EQ.0) RETURN
      IF (NSTE.EQ.0) RETURN
C
C     ESTABLISH THE DEGREES OF FREEDOM INTO WHICH
C     THE PRESSURE LOADS ACT
C
      DO 200 K=1,NPR2
      LL=0
      DO 200 I=1,NODE2
      II=NODPR(I,K)
      KK=1
      IF (IDOF(1).EQ.1) KK=0
      DO 200 L=2,3
      LL=LL + 1
      IDOFR(LL,K)=0
      IF (IDOF(L).EQ.1 .OR. II.EQ.0) GO TO 200
      KK=KK + 1
      IDOFR(LL,K)=ID(KK,II)
  200 CONTINUE
C
C     CALCULATE PRESSURE LOADS
C
      DO 390 K=1,NPR2
      NODE=0
C
      DO 392 I=1,NDFR2
  392 PR(I,K)=0.0
      DO 410 I=1,NODE2
      N=NODPR(I,K)
      IF (N.EQ.0) GO TO 410
      NODE=NODE + 1
      Y2(I)=Y(N)
      Z2(I)=Z(N)
  410 CONTINUE
C
      NV=2*NODE
      DO 420 J=1,3
C
      CALL PLVEC2 (XGL(J),VEC,Y2,Z2,THICV(K),PRINT(1,K),PRINT(2,K),
     1            IELTYP(K),IDIRN(K),NODE)
C
      DO 430 I=1,NV
  430 PR(I,K)=PR(I,K) + WGTL(J)*VEC(I)
  420 CONTINUE
C
C     ROTATE TO SKEW SYSTEM
C
      IF (NSKEWS.EQ.0) GO TO 390
      DO 600 I=1,NODE
      J=NODPR(I,K)
      NRST=NODSYS(J)
      IF (NRST.EQ.0) GO TO 600
      II=2*I - 1
      CALL DIRCOS (RSDCOS,PR(II,K),NRST,1,2,2)
  600 CONTINUE
C
  390 CONTINUE
C
C     ADD NODAL POINT FORCES TO LOAD VECTOR
C
      REWIND NRLOAD
      REWIND NWLOAD
      DO 530 L=1,NSTE
      READ (NRLOAD) R
      DO 540 K=1,NPR2
      NC=NCUR(K)
      NSTEA=ARTM(K)/DT
      NSTEF=L - NSTEA
      IF (NSTEF.LE.0) GO TO 540
      AFACT=NSTEA - ARTM(K)/DT + 1.
      DO 550 I=1,NDFR2
      II=IDOFR(I,K)
      RGFR=RG(NC,NSTEF)
      IF (ARTM(K).EQ.0.) GO TO 539
      RGFR=RGST(NC)*(1.0 - AFACT) + RGFR*AFACT
      IF (NSTEF.LE.1) GO TO 539
      RGFR=RG(NC,NSTEF-1)*(1.0 - AFACT) + RG(NC,NSTEF)*AFACT
  539 IF (II) 525,550,545
C
C     TRANSFER LOADS FROM CONSTRAINED DOF
C
  525 NCE=-II
      ND=NID(NCE)
      DO 535 J=1,ND
      II=IDI(J,NCE)
      FRAC=BETA(J,NCE)
  535 R(II)=R(II) + PR(I,K)*RGFR*FRAC
      GO TO 550
C
  545 R(II)=R(II) + PR(I,K)*RGFR
C
  550 CONTINUE
  540 CONTINUE
      WRITE (NWLOAD) R
      IF (IDEBUG.EQ.5) WRITE (6,6000) (R(I),I=1,NEQ)
  530 CONTINUE
C
      RETURN
C
 1000 FORMAT(3I5,4F10.0,2I5 / 3I5)
 2000 FORMAT (////,50H  T W O - D I M E N S I O N A L  P R E S S U R E
     1,       24HL O A D I N G  D A T A                    ///,
     2        4X,6HIELTYP,4X,4HNCUR,3X,6HNODPR1,3X,6HNODPR2,3X,6HNODPR3,
     3        7X,8HPRINT(1),7X,8HPRINT(2),8X,5HTHICV,10X,4HARTM,10X,
     4        2HKL,10X,5HIDIRN //)
 2005 FORMAT (2X,5I8,3X,4E15.5,5X,I5,7X,I5 /)
 2010 FORMAT (55H **ERROR,  NODAL POINT OF PRESSURE APPLICATION IS NOT I
     1 28HN RANGE OF NODAL POINTS USED/24H           PRESSURE SET
     2 7HNUMBER=,I5,24H     NODAL POINT NUMBER=,I5)
 2020 FORMAT (55H **ERROR,  TIME FUNCTION CURVE SPECIFIED FOR PRESSURE S
     1 21HET HAS NOT BEEN INPUT/24H           PRESSURE SET
     2 7HNUMBER=,I5,26H     TIME FUNCTION NUMBER=,I5)
 2030 FORMAT (41H **WARNING,  ARRIVAL TIME OF PRESSURE SET,I5,
     1 31H IS NOT WITHIN TIME OF SOLUTION)
C
 3000 FORMAT (78H **WARNING**  (PRINT(1)2 - PRINT(1)1) IS NOT EQUAL TO (
     1PRINT(2)2 - PRINT(2)1). /,14X,50HCHECK 2/D PRESSURE LOADING INPUT
     2DATA    (TODPRL)     )
 3010 FORMAT (82H **ERROR**  THE NUMBER OF 2/D PRESSURE LOADING SET INPU
     1T OR GENERATED EXCEED NPR2.  /,12X,19HSTOPPED IN (TODPRL)      )
 6000 FORMAT (10F12.5/)
      END
C *CDC* *DECK THDPRL
C *UNI* )FOR,IS N.THDPRL,R.THDPRL
      SUBROUTINE THDPRL(ID,RG,RGST,R,X,Y,Z,PR,IDOFR,ARTM,NCUR,
     1                   PRINT,NODPR,KL,IDIRN,IFACE,IPRCOR,NID,IDI,BETA,
     2                   RSDCOS,NODSYS,NPR,NDUMMY,NDFRP,NDOF,NTFND,NEQ,
     4                   NIDM,IDOF,NSKEWS,NRLOAD,NWLOAD,NUMNPP)
C
C     SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT LOADS
C     DUE TO PRESSURE ON 3/D ELEMENT FACE,ISO/BEAM ELEMENT,PLATE ELEMENT
C     AND SHELL ELEMENT
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C     V A R I A B L E S :
C
C
C     NODPR = NODES TO WHICH PRESSURE LOADING IS APPLIED
C     PRINT = PRESSURE INTENSITIES AT NODAL POINTS
C     PR    = WORK EQUIVALENT NODAL POINT PRESSURE LOADS
C     IDOFR = DEGREES OF FREEDOM INTO WHICH LOADS IN PR
C             HAVE TO BE ADDED
C     NPR   = NUMBER OF PRESSURE LOAD SETS
C     NODEP = NUMBERS OF NODES PER PRESSURE SET
C     NDFRP = NODEP*3
C     RG    = INTERPOLATED VALUES OF TIME FUNCTIONS
C     ARTM  = ARRIVAL TIMES OF PRESSURE LOADS
C     NCUR  = TIME FUNCTIONS CORRESPONDING TO PRESSURE LOADS
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      IMPLICIT REAL*8 (A-H,O-Z)
      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 /PRSHAP/ KSHAPE
      COMMON /TIMFN/ TEND,NTFN,NPTM
      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
      DIMENSION ID(NDOF,1),RG(NTFND,1),NODPR(NDUMMY,1),PRINT(4,1),
     1          IDOFR(NDFRP,1),NCUR(1),R(NEQ),ARTM(1),X(1),Y(1),Z(1),
     2          PR(NDFRP,1),IFACE(1),XX(3,16),IPRCOR(1),
     3          RGST(1),KL(1),IDIRN(1),NODPRM(16),PRINTM(4),NODES(16)
      DIMENSION NID(1),IDI(NIDM,1),BETA(NIDM,1),RSDCOS(1),NODSYS(1)
     1         ,IDOF(6)
      DIMENSION PLOAD(48)
      DIMENSION XTYPE(8),ANODPR(2)
      DATA XTYPE /8H PLATE  ,8HISO/BEAM,8H  3-D   ,8H SHELL  ,
     1 5H NPPL,5HNP3DB,5H NPR3,5H NPSH /
      DATA ANODPR /4HNODP,6H  KK  /
C
C
C
C     R E A D   A N D  G E N E R A T E  P R E S S U R E
C     L O A D    I N F O R M A T I O N
C
C
      L=1
      K=1
      NODEP=NDUMMY
      IF (NODEP.EQ.5) NODEP=4
C
C     IDUMMY=1 ,2 ,3 ,4 , FOR PLATE,ISO/BEAM,3/D ELEMENT,SHELL RESP.
C
      IDUMMY=1 + NODEP/4 - NODEP/16
      IF (IDUMMY.NE.2) GO TO 10
    8 READ(5,1050) NCURM,IDIRNM,(PRINTM(I),I=1,4),
     1             IFACEM,ARTMM,KLM,IDEBUG,
     1             NODAUX,(NODPRM(I),I=1,4)
      IF (K-L) 50,20,50
   10 READ(5,1000) NCURM,IDIRNM,(PRINTM(I),I=1,4),ARTMM,KLM,IDEBUG,
     1             (NODPRM(I),I=1,NODEP)
C
      IF (K.NE.L) GO TO 50
C
C     SAVE LOAD INFORMATION
C
   20 NCUR(K)=NCURM
      DO 35 I=1,NODEP
   35 NODPR(I,K)=NODPRM(I)
      IF (IDUMMY.NE.2) GO TO 37
      NODPR(5,K) = NODAUX
      IFACE(K) = IFACEM
   37 DO 36 I=1,4
   36 PRINT(I,K)=PRINTM(I)
      KL(K)=KLM
      IDIRN(K)=IDIRNM
      ARTM(K)=ARTMM
C
C     SET SPATIAL ISOTROPY CORRECTION PARAMETER
C
      IF (KSHAPE.EQ.0) GO TO 48
      ICOLPS=1
      IF (NODEP.NE.8 .AND. NODEP.NE.12) GO TO 46
      IF (NODPRM(1).NE.NODPRM(4) .OR. NODPRM(1).NE.NODPRM(8)) GO TO 46
      IF (NODEP-10) 44,44,45
   44 ICOLPS=2
      GO TO 46
   45 IF (NODPRM(1).EQ.NODPRM(12)) ICOLPS=3
   46 IPRCOR(K)=ICOLPS
C
   48 IF (KLM.EQ.0) GO TO 90
      IF (L.EQ.NPR) GO TO 99
C
      L=L + 1
      IF (IDUMMY-2) 10 ,8 ,10
C
C     GENERATE PRESSURE LOAD INFORMATION
C
   50 KK=K
      NGNOD=(NODPRM(1) - NODPR(1,KK))/KL(KK)
      DARTM=(ARTMM - ARTM(KK))/NGNOD
      DPR=(PRINTM(1) - PRINT(1,KK))/NGNOD
      NJ=NGNOD - 1
      DO 52 J=1,NJ
      K=K + 1
      NCUR(K)=NCUR(KK)
      KL(K)=KL(KK)
      IDIRN(K)=IDIRN(KK)
      IF (IDUMMY.NE.2) GO TO 51
      NODPR(5,K) = NODPR(5,KK)
      IFACE(K) = IFACE(KK)
   51 DO 53 I=1,NODEP
      NODPR(I,K)=NODPR(I,K-1) + KL(KK)
      IF (NODPR(I,KK).EQ.0) NODPR(I,K)=0
   53 CONTINUE
      DO 54 I=1,4
   54 PRINT(I,K)=PRINT(I,K-1) + DPR
      ARTM(K)=ARTM(K-1) + DARTM
   52 CONTINUE
C
      IF (K.LE.NPR) GO TO 55
      WRITE(6,3010) XTYPE(IDUMMY), XTYPE(IDUMMY+4)
      STOP
   55 K=K + 1
      L=K
      IF (L.LE.NPR) GO TO 20
      GO TO 99
C
   90 L=L + 1
      K=L
      IF (L.GT.NPR) GO TO 99
      IF (IDUMMY-2) 10,8,10
C
   99 CONTINUE
C
C     WRITE PRESSURE LOAD INFORMATION
C
      IF (IDATWR.GT.1) GO TO 130
      WRITE(6,2000) XTYPE(IDUMMY)
      IF (IDUMMY.EQ.1) WRITE(6,2105) (ANODPR(1),I,I=1,3)
      IF (IDUMMY.EQ.2) WRITE(6,2100) (ANODPR(1),I,I=1,4),ANODPR(2)
      IF (IDUMMY.LE.2) GO TO 130
      WRITE(6,2110) (ANODPR(1),I,I=1,4)
      WRITE(6,2120) (ANODPR(1),I,I=5,NODEP)
  130 CONTINUE
C
      DO 100 K=1,NPR
      IF(IDATWR.GT.1) GO TO 140
C
      IF (IDUMMY-2) 170,180,185
  170 WRITE(6,2135) (NODPR(I,K),I=1,3),NCUR(K),ARTM(K),
     1              (PRINT(I,K),I=1,3),KL(K),IDIRN(K)
      GO TO 140
C
  180 WRITE(6,2130) (NODPR(I,K),I=1,4),NODPR(5,K),NCUR(K),ARTM(K),
     1              (PRINT(I,K),I=1,4),IFACE(K),KL(K),IDIRN(K)
      GO TO 140
C
  185 WRITE(6,2140) (NODPR(I,K),I=1,4),NCUR(K),ARTM(K),
     1              (PRINT(I,K),I=1,4),KL(K),IDIRN(K)
      WRITE(6,2150) (NODPR(I,K),I=5,NODEP)
C
  140 CONTINUE
C
C     ERROR TESTS
C
      DO 110 I=1,NODEP
      IF (NODPR(I,K).LE.NUMNPP) GO TO 110
      WRITE(6,2010) K,NODPR(I,K)
      STOP
  110 CONTINUE
C
      IF (NCUR(K).GE.1 .AND. NCUR(K).LE.NTFN) GO TO 120
      WRITE(6,2020) K,NCUR(K)
      STOP
C
  120 IF (ARTM(K).GE.0. .AND. ARTM(K).LE.TEND) GO TO 100
      WRITE (6,2030) K
C
  100 CONTINUE
      IF (MODEX.EQ.0) RETURN
      IF (NSTE.EQ.0) RETURN
C
C     ESTABLISH THE DEGREES OF FREEDOM INTO WHICH
C     THE PRESSURE LOADS ACT
C
      DO 200 K=1,NPR
      DO 210 L=1,NDFRP
  210 IDOFR(L,K)=0
      LL=0
      DO 200 I=1,NODEP
      II=NODPR(I,K)
      KK=0
      DO 200 L=1,3
      LL=LL + 1
      IDOFR(LL,K)=0
      IF (II.EQ.0 .OR. IDOF(L).EQ.1) GO TO 200
      KK=KK + 1
      IDOFR(LL,K)=ID(KK,II)
  200 CONTINUE
C
C     CALCULATE PRESSURE LOADS
C
      DO 390 K=1,NPR
      DO 392 I=1,NDFRP
      PLOAD(I)=0.0
  392 PR(I,K)=0.
      DO 410 I=1,NODEP
      DO 402 J=1,3
  402 XX(J,I)=0.
      N=NODPR(I,K)
      NODES(I)=NODPR(I,K)
      IF (N.EQ.0) GO TO 410
      XX(1,I)=X(N)
      XX(2,I)=Y(N)
      XX(3,I)=Z(N)
  410 CONTINUE
C
      DO 403 I=1,4
  403 PRINTM(I)=PRINT(I,K)
C
      IF (IDUMMY - 2) 155,160,165
  155 CALL PLVECP (NODES,XX,PLOAD,PRINTM,IDIRN(K))
      GO TO 175
C
  160 NODAUX=NODPR(5,K)
      XX(1,5)=X(NODAUX)
      XX(2,5)=Y(NODAUX)
      XX(3,5)=Z(NODAUX)
      CALL PLISBM (NODES,XX,PLOAD,PRINTM,IDIRN(K),IFACE(K))
      GO TO 175
C
  165 CALL PLVEC3 (NODES,XX,PLOAD,PRINTM,IDIRN(K),NODEP,IPRCOR(K))
  175 CONTINUE
      DO 420 I=1,NDFRP
  420 PR(I,K)=PLOAD(I)
C
C     ROTATE TO SKEW SYSTEM
C
      IF (NSKEWS.EQ.0) GO TO 390
      DO 600 I=1,NODEP
      J=NODPR(I,K)
      NRST=0
      IF (J.GT.0) NRST=NODSYS(J)
      IF (NRST.EQ.0) GO TO 600
      II=3*(I-1) + 1
      CALL DIRCOS (RSDCOS,PR(II,K),NRST,1,3,2)
  600 CONTINUE
C
  390 CONTINUE
C
C     ADD NODAL POINT FORCES TO LOAD VECTOR
C
      REWIND NRLOAD
      REWIND NWLOAD
      DO 530 L=1,NSTE
      READ (NRLOAD) R
      DO 540 K=1,NPR
      NC=NCUR(K)
      NSTEA=ARTM(K)/DT
      NSTEF=L - NSTEA
      IF (NSTEF.LE.0) GO TO 540
      AFACT=NSTEA - ARTM(K)/DT + 1.
      DO 550 I=1,NDFRP
      II=IDOFR(I,K)
      RGFR=RG(NC,NSTEF)
      IF (ARTM(K).EQ.0.) GO TO 539
      RGFR=RGST(NC)*(1.0 - AFACT) + RGFR*AFACT
      IF (NSTEF.LE.1) GO TO 539
      RGFR=RG(NC,NSTEF-1)*(1.0 - AFACT) + RG(NC,NSTEF)*AFACT
  539 IF (II) 525,550,545
C
C     TRANSFER LOADS FROM CONSTRAINED DOF
C
  525 NCE=-II
      ND=NID(NCE)
      DO 535 J=1,ND
      II=IDI(J,NCE)
      FRAC=BETA(J,NCE)
  535 R(II)=R(II) + PR(I,K)*RGFR*FRAC
      GO TO 550
C
  545 R(II)=R(II) + PR(I,K)*RGFR
C
  550 CONTINUE
  540 CONTINUE
      WRITE (NWLOAD) R
      IF (IDEBUG.EQ.5) WRITE(6,6000) (R(I),I=1,NEQ)
  530 CONTINUE
C
      RETURN
C
 1000 FORMAT(2I5,5F10.0,2I5/16I5)
 1050 FORMAT(2I5,4F10.0,I5,F10.0,2I5/16I5)
 2000 FORMAT(////,2X,A8,1X,41H P R E S S U R E  L O A D I N G  D A T A )
 2100 FORMAT(//,1X,4(1X,A4,I2),2X,A6,4X,4HNCUR,5X,4HARTM,
     1       5X,8HPRINT(1),5X,8HPRINT(2),5X,8HPRINT(3),5X,8HPRINT(4),
     1       3X,5HIFACE,4X,2HKL,3X,5HIDIRN)
 2105 FORMAT(//,3X,3(2X,A4,I2),6X,4HNCUR,8X,4HARTM,10X,
     1       8HPRINT(1),6X,8HPRINT(2),6X,8HPRINT(3),
     2       7X,2HKL,4X,5HIDIRN )
 2110 FORMAT (//3X,4(1X,A4,I3),6X,4HNCUR,7X,4HARTM,8X,
     1       8HPRINT(1),6X,8HPRINT(2),6X,8HPRINT(3),6X,8HPRINT(4),
     2       7X,2HKL,4X,5HIDIRN)
 2120 FORMAT(3X,4(1X,A4,I3),/,3X,4(1X,A4,I3),/,3X,4(1X,A4,I3))
 2130 FORMAT(I5,3I7,I9,4X,I5,2X,E10.4,4(2X,E11.5),I4,2X,2I6)
 2135 FORMAT(1X,3I8,4X,I7,5X,E10.4,3X,3(3X,E11.5),I8,I6)
 2140 FORMAT(1X,4I8,4X,I7,5X,E10.4,1X,4(3X,E11.5),I8,I6)
 2150 FORMAT(3(1X,4I8,/))
 2010 FORMAT (55H **ERROR,  NODAL POINT OF PRESSURE APPLICATION IS NOT I
     1 28HN RANGE OF NODAL POINTS USED/24H           PRESSURE SET
     2 7HNUMBER=,I5,24H     NODAL POINT NUMBER=,I5)
 2020 FORMAT (55H **ERROR,  TIME FUNCTION CURVE SPECIFIED FOR PRESSURE S
     1 21HET HAS NOT BEEN INPUT/24H           PRESSURE SET
     2 7HNUMBER=,I5,26H     TIME FUNCTION NUMBER=,I5)
 2030 FORMAT (41H **WARNING,  ARRIVAL TIME OF PRESSURE SET,I5,
     1 31H IS NOT WITHIN TIME OF SOLUTION)
C
 3010 FORMAT(26H **ERROR**  THE NUMBER OF ,A8,1X,48H PRESSURE LOADING SE
     1T INPUT OR GENERATED EXCEED ,A5,/,12X,20H STOPPED IN (THDPRL)   )
 6000 FORMAT (10F12.5/)
      END
C *CDC* *DECK PLISBM
C *UNI* )FOR,IS N.PLISBM, R.PLISBM
      SUBROUTINE PLISBM(NODES,XX,PLOAD,PRINT,IDIRN,IFACE)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     SUBROUTINE TO CALCULATE EQUIVALENT NODAL FORCES DUE TO
C     PRESSURE LOADING ON AN ISO/BEAM ELEMENT
C
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      DIMENSION NODES(16),XX(3,16),PLOAD(48)
      DIMENSION H(4),Q(4),PRINT(4),PRESS(4)
      DIMENSION D(9),CONST(5)
      DATA CONST / 0.2113249D0,0.7745967D0,0.2254033D0,0.7917045D0,
     1             0.0099716D0/
C
C     TO EVALUATE THE NUMBER OF NODES PRESENT
C
      NUM=0
      DO 120 I=1,4
      PRESS(I)=0.0
  120 IF (NODES(I).GT.0) NUM=NUM+1
C
C     INTERPOLATION OF PRESSURE
C
C     PRESS(4) CONTAINS LINEARLY INTERPOLATED VALUES OF PRESSURE
C     AT THE INTEGRATION POINTS
C     CONST(5) CONTAINS MULTIPLIERS USED ON THE NODAL VALUES OF PRESSURE
C     FOR OBTAINING MAGNITUDE OF INTERPOLATED PRESSURE
C
      IF (NUM.NE.2) GO TO 130
      P21=CONST(1)*(PRINT(2)-PRINT(1))
      PRESS(1)=PRINT(1) + P21
      PRESS(2)=PRINT(2) - P21
C
  130 IF (NUM.NE.3) GO TO 140
      PRESS(1)=CONST(2)*PRINT(1) + CONST(3)*PRINT(3)
      PRESS(2)=PRINT(3)
      PRESS(3)=CONST(2)*PRINT(2) + CONST(3)*PRINT(3)
C
  140 IF (NUM.LT.4) GO TO 145
      P24=PRINT(2)-PRINT(4)
      P13=PRINT(1)-PRINT(3)
      PRESS(1)=PRINT(3) + CONST(4)*P13
      PRESS(2)=PRINT(3) + CONST(5)*P13
      PRESS(3)=PRINT(4) + CONST(5)*P24
      PRESS(4)=PRINT(4) + CONST(4)*P24
  145 CONTINUE
C
C     LINE INTEGRATION LOOP
C
      DO 150 LR=1,NUM
      R=XG(LR,NUM)
C
C     EVALUATE THE INTERPOLATION FUNCTIONS AND DERIVATIVES
C
      RR  =1.0-R*R
      H(1)=0.50*(1.0-R)
      H(2)=0.50*(1.0+R)
      Q(1)=-0.50
      Q(2)= 0.50
C
      DO 20 I=3,4
      H(I)=0.0
   20 Q(I)=0.0
C
C     QUADRATIC AND CUBIC NODES
C
      IF (NODES(4).LE.0) GO TO 25
      H(3)=(0.5625-1.6875*R)*RR
      H(4)=(0.5625+1.6875*R)*RR
      Q(3)= 5.0625*R*R - 1.125*R - 1.6875
      Q(4)=-5.0625*R*R - 1.125*R + 1.6875
      H(1)=H(1) - (2.0*H(3) + H(4))/3.0
      H(2)=H(2) - (2.0*H(4) + H(3))/3.0
      Q(1)=Q(1) - (2.0*Q(3) + Q(4))/3.0
      Q(2)=Q(2) - (2.0*Q(4) + Q(3))/3.0
      GO TO 35
C
   25 IF (NODES(3).LE.0) GO TO 35
      H(3)=RR
      Q(3)=-2.0*R
      H(1)=H(1) - H(3)/2.0
      H(2)=H(2) - H(3)/2.0
      Q(1)=Q(1) - Q(3)/2.0
      Q(2)=Q(2) - Q(3)/2.0
C
   35 D(1)=XX(1,5)
      D(2)=XX(2,5)
      D(3)=XX(3,5)
      DO 30 I=4,9
   30 D(I)=0.0
      XTB=0.0
      XTA=0.0
      XNN=0.0
C
C
C     TO COMPUTE THE JACOBIAN AND THE VECTORS IN THE DIRECTIONS OF
C     R,S AND T AXES AS NEEDED.
C     D(1),D(2),D(3) CONTAIN COMPONANTS OF A VECTOR IN R-S PLANE
C     D(4),D(5),D(6) CONTAIN COMPONANTS OF A VECTOR ALONG R AXIS
C     D(7),D(8),D(9) CONTAIN
C                           COMPONANTS OF S AXIS, IF IFACE .EQ. 1
C                           COMPONANTS OF T AXIS, IF IFACE .EQ. 2
C
C     LAGRANGE IDENTITY IS USED IN CALCULATION OF VECTOR ALONG S AXIS
C
      DO 50 I=1,3
      DO 40 J=1,4
      IF (NODES(J).LE.0) GO TO 40
      D(I)  =D(I)   - H(J)*XX(I,J)
      D(I+3)=D(I+3) + Q(J)*XX(I,J)
   40 CONTINUE
      XTB = D(I+3)*D(I+3) + XTB
      XTA=  D(I)*D(I+3) + XTA
   50 CONTINUE
      XTT = DSQRT(XTB)
      IF (XTT .GT. 1.0D-06) GO TO 60
C
      WRITE (6,2000) R,XTT
      STOP
C
C
C      LOAD APPLIED IN THE R-S PLANE
C
   60 IF (IFACE.EQ.2) GO TO 64
      DO 68 I=1,3
      J=I+6
      D(J) = XTB*D(I) - XTA*D(I+3)
      XNN = XNN + D(J)*D(J)
   68 CONTINUE
      XNN=DSQRT(XNN)
      GO TO 70
C
C     LOAD APPLIED IN THE R-T PLANE
C
   64 D(7) = D(5)*D(3) - D(6)*D(2)
      D(8) = D(6)*D(1) - D(3)*D(4)
      D(9) = D(4)*D(2) - D(5)*D(1)
      XNN = D(7)*D(7) + D(8)*D(8) + D(9)*D(9)
      XNN = DSQRT(XNN)
C
C     CALCULATION OF PRESSURE LOADS
C
   70 FACTOR=WGT(LR,NUM)*XTT*PRESS(LR)
      DO 100 K=1,4
      IF (NODES(K).EQ.0) GO TO 100
      XL=FACTOR*H(K)
      I1=1
      I2=3
      IF (IDIRN.EQ.0) GO TO 80
      I1=IDIRN
      I2=I1
   80 DO 90 I=I1,I2
      J=3*(K-1)+I
   90 PLOAD(J)=PLOAD(J) - XL*D(I+6)/XNN
  100 CONTINUE
  150 CONTINUE
C
 2000 FORMAT(//,23H**ERROR** ZERO JACOBIAN,/17X,9HJACOBIAN=,E12.4,
     1/12X,14HCO-ORDINATE R=,F7.5)
      RETURN
      END
C *CDC* *DECK BMLOAD
C *UNI* (FOR.IS N.BMLOAD,R.BMLOAD
      SUBROUTINE BMLOAD (ID,RG,RGST,R,X,Y,Z,BMLD,IDOFR,ARTM,NCUR,
     1                   FAC,ND,KL,IDIRN,NID,IDI,BETA,RSDCOS,NODSYS,
     2                   IFACE,IDOF,NDOF,NTFND,NEQ,NIDM,NSKEWS,NRLOAD,
     3                   NWLOAD,NUMNPP)
C
C      SUBROUTINE TO CALCULATE CONCENTRATED NODAL POINT LOADS
C      DUE TO A DISTRIBUTED LOAD ON A BEAM FACE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
C     VARIABLES
C     NPBM  = NUMBER OF BEAM DISTRIBUTED LOADS
C     ND    = NODES IN BEAM ELEMENT
C             1 ORIGIN OF R AXIS
C             2 IN DIRECTION OF R AXIS
C             3 NODE IN R - S PLANE
C     IDOFR = THE EQUATION NUMBERS FOR THE BEAM DOF
C     IFACE = FACE TO WHICH LOADING IS APPLIED
C             1 S FACE
C             2 T FACE
C     FAC   = LOADING FACTORS AT NODES 1 AND 2
C     TEMP  = NODAL LOAD VECTOR IN ELEMENT COORDINATES
C     BMLD  = GLOBAL NODAL LOAD VECTORS FOR EACH ELEMENT
C     RG    = VALUE OF TIME FUNCTION AT EACH STEP
C     RGST  = VALUE OF TIME FUNCTION AT T=0.
C     ARTM  = ARRIVAL TIME OF DISTRIBUTED LOADS
C     NCUR  = TIME FUNCTIONS CORRESPONDING TO DISTRIBUTED LOAD
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      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 /TIMFN/ TEND,NTFN,NPTM
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      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
      DIMENSION IDIRN(1),NID(1),IDI(NIDM,1),NODSYS(1),IDOF(1),NCUR(1),
     1          IDOFR(12,1),ID(NDOF,1),ND(3,1),IFACE(1),KL(1),ARTM(1),
     2          FAC(2,1),X(1),Y(1),Z(1),BMLD(12,1),BETA(NIDM,1),
     3          RG(NTFND,1),RGST(1),R(NEQ)
      DIMENSION TEMP(12),DCOS(3,3)
C
      IF(IDATWR.LE.1)WRITE(6,2000)
C
      L=1
      K=1
C
C
C     READ AND GENERATE BEAM DISTRIBUTED LOAD INFORMATION
C
C
   10 CONTINUE
      READ (5,1000) NCURM,IDIRNM,FAC1M,FAC2M,IFACEM,ARTMM,KLM,IDEBUG,
     1              ND1M,ND2M,ND3M
      IF (K.NE. L) GO TO 50
C
C     SAVE LOAD INFORMATION
C
   20 CONTINUE
      NCUR(K)=NCURM
      ND(1,K)=ND1M
      ND(2,K)=ND2M
      ND(3,K)=ND3M
      IFACE(K)=IFACEM
      FAC(1,K)=FAC1M
      FAC(2,K)=FAC2M
      ARTM(K)=ARTMM
      IDIRN(K)=IDIRNM
      KL(K)=KLM
      IF(KLM.EQ.0)GO TO 90
      IF(L.EQ.NPBM)GO TO 100
      L=L + 1
      GO TO 10
C
C     GENERATE DISTRIBUTED LOAD INFORMATION
C
   50 CONTINUE
      KK=K
      NGNOD=(ND1M-ND(1,KK))/KL(KK)
      DFC1=(FAC1M-FAC(1,KK))/NGNOD
      DFC2=(FAC2M-FAC(2,KK))/NGNOD
      DF=DFC1-DFC2
      IF(DABS(DF).GT.1.D-4)WRITE(6,3000)
      DARTM=(ARTMM-ARTM(KK))/NGNOD
      NJ=NGNOD-1
      IF(NJ.EQ.0)GO TO 70
      DO 60 J=1,NJ
      K=K+1
      NCUR(K)=NCUR(KK)
      ND(1,K)=ND(1,K-1)+KL(KK)
      ND(2,K)=ND(2,K-1)+KL(KK)
      ND(3,K)=ND(3,KK)
      IFACE(K)=IFACE(KK)
      FAC(1,K)=FAC(1,K-1)+DFC1
      FAC(2,K)=FAC(2,K-1)+DFC2
      ARTM(K)=ARTM(K-1)+DARTM
      KL(K)=KL(KK)
      IDIRN(K)=IDIRN(KK)
   60 CONTINUE
      IF(K.LE.NPBM)GO TO 70
      WRITE(6,3000)
      STOP
   70 CONTINUE
      K=K+1
      L=K
      IF(L.LE.NPBM)GO TO 20
      GO TO 100
   90 CONTINUE
      L=L+1
      K=L
      IF(L.LE.NPBM)GO TO 10
  100 CONTINUE
C
C     WRITE BEAM DISTRIBUTED LOAD INFORMATION
C
      DO 110 I=1,NPBM
      IF(IDATWR.LE.1)
     1WRITE(6,2005)NCUR(I),ND(1,I),ND(2,I),ND(3,I),IFACE(I),FAC(1,I),
     2             FAC(2,I),ARTM(I),KL(I),IDIRN(I)
C
C     ERROR TESTS
C
      IF(ND(1,I).LE.NUMNPP .AND. ND(1,I).GT.0)GO TO 120
      WRITE(6,2010)I,ND(1,I)
      STOP
  120 CONTINUE
      IF(ND(2,I).LE.NUMNPP .AND. ND(2,I).GT.0)GO TO 130
      WRITE(6,2010)I,ND(2,I)
      STOP
  130 CONTINUE
      IF(ND(3,I).LE.NUMNPP .AND. ND(3,I).GT.0)GO TO 140
      WRITE(6,2010)I,ND(3,I)
      STOP
  140 CONTINUE
      IF(NCUR(I).GE.1 .AND. NCUR(I).LE.NTFN)GO TO 150
      WRITE(6,2015)I,NCUR(I)
      STOP
  150 CONTINUE
      IF(IFACE(I).GT.0 .AND. IFACE(I).LT.3)GO TO 160
      WRITE(6,2020)I,IFACE(I)
      STOP
  160 CONTINUE
      IF(ARTM(I).GE.0. .AND. ARTM(I).LE.TEND)GO TO 170
      WRITE(6,2025)I,ARTM(I)
  170 CONTINUE
  110 CONTINUE
      IF(MODEX.EQ.0)RETURN
      IF(NSTE.EQ.0)RETURN
C
C     ESTABLISH THE DEGREES OF FREEDOM INTO WHICH DISTRIBUTED LOAD ACTS
C
      DO 225 I=1,NPBM
      DO 230 J=1,2
      K=ND(J,I)
      LL=0
      DO 240 L=1,6
      LLL=(J-1)*6+L
      IDOFR(LLL,I)=0
      IF(IDOF(L).EQ.1)GO TO 240
      LL=LL+1
      IDOFR(LLL,I)=ID(LL,K)
  240 CONTINUE
  230 CONTINUE
  225 CONTINUE
      DO 180 I=1,NPBM
C
C     FIND COORDINATES OF END LOADS
C
      NTEMP=ND(1,I)
      X1=X(NTEMP)
      Y1=Y(NTEMP)
      Z1=Z(NTEMP)
      NTEMP=ND(2,I)
      X2=X(NTEMP)
      Y2=Y(NTEMP)
      Z2=Z(NTEMP)
      NTEMP=ND(3,I)
      X3=X(NTEMP)
      Y3=Y(NTEMP)
      Z3=Z(NTEMP)
C
C     CALCULATE DIRECTION COSINES FROM ELEMENT TO GLOBAL SYSTEM
C
      CALL DRCOS(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,DCOS,IERR)
      IF(IERR.EQ.0)GO TO 190
      WRITE(6,2030)I,IERR
      STOP
  190 CONTINUE
      RL=DSQRT((X1-X2)*(X1-X2)+(Y1-Y2)*(Y1-Y2)+(Z1-Z2)*(Z1-Z2))
C
C     ASSEMBLE CANONICAL LOAD IN ELEMENT SYSTEM
C
      IF(IFACE(I).EQ.2)GO TO 200
      TEMP(1)=0.
      TEMP(2)=-(7.*FAC(1,I)+3.*FAC(2,I))*RL/20.
      TEMP(3)=0.
      TEMP(4)=0.
      TEMP(5)=0.
      TEMP(6)=-(3.*FAC(1,I)+2.*FAC(2,I))*RL*RL/60.
      TEMP(7)=0.
      TEMP(8)=-(3.*FAC(1,I)+7.*FAC(2,I))*RL/20.
      TEMP(9)=0.
      TEMP(10)=0.
      TEMP(11)=0.
      TEMP(12)=(2.*FAC(1,I)+3.*FAC(2,I))*RL*RL/60.
      GO TO 210
  200 CONTINUE
      TEMP(1)=0.
      TEMP(2)=0.
      TEMP(3)=-(7.*FAC(1,I)+3.*FAC(2,I))*RL/20.
      TEMP(4)=0.
      TEMP(5)=(3.*FAC(1,I)+2.*FAC(2,I))*RL*RL/60.
      TEMP(6)=0.
      TEMP(7)=0.
      TEMP(8)=0.
      TEMP(9)=-(3.*FAC(1,I)+7.*FAC(2,I))*RL/20.
      TEMP(10)=0.
      TEMP(11)=-(2.*FAC(1,I)+3.*FAC(2,I))*RL*RL/60.
      TEMP(12)=0.
  210 CONTINUE
C
C     ROTATE TO GLOBAL SYSTEM
C
      CALL ROTATE(BMLD(1,I),TEMP,DCOS)
      IF(NSKEWS.EQ.0)GO TO 250
C
C     ROTATE TO SKEW COORDINATE SYSTEMS
C
      M=1
      DO 220 K=1,2
      J=ND(K,I)
      NRST=NODSYS(J)
      IF(NRST.EQ.0)GO TO 220
      DO 260 L=1,2
      CALL DIRCOS(RSDCOS,BMLD(M,I),NRST,1,3,2)
      M=M+3
  260 CONTINUE
  220 CONTINUE
  250 CONTINUE
  180 CONTINUE
C
C     ADD NODAL POINT FORCES TO LOAD VECTOR
C
      REWIND NRLOAD
      REWIND NWLOAD
      DO 300 I=1,NSTE
      READ(NRLOAD)R
      DO 320 J=1,NPBM
      NC=NCUR(J)
      NSTEA=ARTM(J)/DT
      NSTEF=I-NSTEA
      IF(NSTEF.LE.0)GO TO 320
      AFACT=DBLE(FLOAT(NSTEA))-ARTM(J)/DT+1.
      RGFR=RG(NC,NSTEF)
      IF(ARTM(J).EQ.0.)GO TO 330
C
C     IF ARTM LANDS BETWEEN TIME STEPS, INTERPOLATE TO FIND TIME FUNCT.
C
      RGFR=RGST(NC)*(1.-AFACT)+RGFR*AFACT
      IF(NSTEF.LE.1)GO TO 330
      RGFR=RG(NC,NSTEF-1)*(1.-AFACT)+RG(NC,NSTEF)*AFACT
  330 CONTINUE
      DO 350 K=1,2
      NDE=ND(K,J)
      NK=(K-1)*6
      DO 360 N=1,6
      NNK=NK+N
      II=IDOFR(NNK,J)
      IF(II)370,360,390
C
C     TRANSFER LOAD FROM CONSTRAINED DOF
C
  370 CONTINUE
      NCE=-II
      NDT=NID(NCE)
      DO 380 M=1,NDT
      II=IDI(M,NCE)
      FRAC=BETA(M,NCE)
      R(II)=R(II)+BMLD(NNK,J)*FRAC*RGFR
  380 CONTINUE
      GO TO 360
  390 CONTINUE
      R(II)=R(II)+BMLD(NNK,J)*RGFR
  360 CONTINUE
  350 CONTINUE
  320 CONTINUE
      WRITE(NWLOAD)R
      IF(IDEBUG.EQ.5)WRITE(6,6000)(R(J),J=1,NEQ)
  300 CONTINUE
      RETURN
 1000 FORMAT(2I5,2F10.0,I5,F10.0,2I5/3I5)
 2000 FORMAT (////,1X,31HB E A M  D I S T R I B U T E D
     1        23H L O A D I N G  D A T A      ///,
     2        9X,4HNCUR,5X,5HND(1),5X,5HND(2),5X,5HND(3),
     3        5X,5HIFACE,4X,6HFAC(1),10X,6HFAC(2),12X,4HARTM,
     4        13X,2HKL,5X,5HIDIRN,//)
 2005 FORMAT (1X,5I10,3E16.8,2I10)
 2010 FORMAT (1X,48H**ERROR, NODAL POINT FOR DISTRIBUTED LOAD IS NOT
     1        30H IN RANGE OF NODAL POINTS USED,/,
     2        14H LOAD SET NO.=,I5,2X,10H NODE NO.=,I5)
 2015 FORMAT (1X,51H**ERROR, TIME FUNCTION CURVE SPECIFIED FOR LOADING ,
     1        25HSET HAS NOT BEEN INPUTTED,/,14H LOAD SET NO.=,
     2        I5,2X,18HTIME FUNCTION NO.=,I5)
 2020 FORMAT (1X,38H**ERROR, ILLEGAL FACE NUMBER SPECIFIED,/,
     1        14H LOAD SET NO.=,I5,2X,9HFACE NO.=,I5)
 2025 FORMAT (1X,35H**WARNING, ARRIVAL TIME OF LOAD SET,I5,
     1        2X,30HIS NOT WITHIN TIME OF SOLUTION,2X,
     2        14H ARRIVAL TIME=,E13.5)
 2030 FORMAT (1X,40H**ERROR IN CALCULATING DIRECTION COSINES,/,
     1        42H IERR=1: ZERO LENGTH BETWEEN NODES 1 AND 2,/,
     2        42H IERR=2: ZERO LENGTH BETWEEN NODES 1 AND 3,/,
     3        38H IERR=3: NODES 1, 2 AND 3 ARE COLINEAR,/,
     4        30H IERR=4: CROSS PRODUCT FAILURE,/,14H LOAD SET NO.=,
     5        I5,2X,5HIERR=,I5)
 3000 FORMAT (1X,49H**WARNING, INCREMENTING OF FAC(1) IS NOT EQUAL TO,
     1        41H INCREMENTING OF FAC(2), CHECK INPUT DATA)
 6000 FORMAT (10E13.5)
      END
C *CDC* *DECK DRCS1
C *UNI* )FOR.IS N.DRCOS,R.DRCOS
      SUBROUTINE DRCOS(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,DCOS,IERR)
C
C     SUBROUTINE TO CALCULATE DIRECTION COSINES BETWEEN ELEMENT AND
C     AND GLOBAL COORDINATE SYSTEM
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DCOS(3,1)
C
      IERR=0
      DX=X2-X1
      DY=Y2-Y1
      DZ=Z2-Z1
      RL=DSQRT(DX*DX+DY*DY+DZ*DZ)
      IF(RL.GT.1.D-8)GO TO 10
      IERR=1
      RETURN
   10 CONTINUE
C
C     ESTABLISH R DIRECTION COSINES
C
      DCOS(1,1)=DX/RL
      DCOS(2,1)=DY/RL
      DCOS(3,1)=DZ/RL
      DX=X3-X1
      DY=Y3-Y1
      DZ=Z3-Z1
      RL=DSQRT(DX*DX+DY*DY+DZ*DZ)
      IF(RL.GT.1.D-8)GO TO 20
      IERR=2
      RETURN
   20 CONTINUE
      DCX=DCOS(2,1)*DZ-DY*DCOS(3,1)
      DCY=DCOS(3,1)*DX-DZ*DCOS(1,1)
      DCZ=DCOS(1,1)*DY-DX*DCOS(2,1)
      RL=DSQRT(DCX*DCX+DCY*DCY+DCZ*DCZ)
      IF(RL.GT.1.D-8)GO TO 30
      IERR=3
      RETURN
   30 CONTINUE
C
C     ESTABLISH T DIRECTION COSINES
C
      DCOS(1,3)=DCX/RL
      DCOS(2,3)=DCY/RL
      DCOS(3,3)=DCZ/RL
      DCX=DCOS(2,3)*DCOS(3,1)-DCOS(2,1)*DCOS(3,3)
      DCY=DCOS(3,3)*DCOS(1,1)-DCOS(1,3)*DCOS(3,1)
      DCZ=DCOS(1,3)*DCOS(2,1)-DCOS(1,1)*DCOS(2,3)
      RL=DSQRT(DCX*DCX+DCY*DCY+DCZ*DCZ)
      IF(RL.GT.1.D-8)GO TO 40
      IERR=4
      RETURN
   40 CONTINUE
C
C     ESTABLISH S DIRECTION COSINES
C
      DCOS(1,2)=DCX/RL
      DCOS(2,2)=DCY/RL
      DCOS(3,2)=DCZ/RL
      RETURN
      END
C *UNI* )FOR.IS N.ROTATE,R.ROTATE
C *CDC* *DECK ROTATE
      SUBROUTINE ROTATE(BLD,TEMP,DCOS)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION BLD(1),TEMP(1),DCOS(3,1)
      DO 5 I=1,12
      BLD(I)=0.
    5 CONTINUE
      DO 10 I=1,4
      JJ=(I-1)*3
      KK=(I-1)*3
      DO 20 J=1,3
      JJJ=JJ+J
      DO 30 K=1,3
      KKK=KK+K
      BLD(JJJ)=BLD(JJJ)+DCOS(J,K)*TEMP(KKK)
   30 CONTINUE
   20 CONTINUE
   10 CONTINUE
      RETURN
      END
C *CDC* *DECK PDISP
C *UNI* )FOR,IS N.PDISP, R.PDISP
      SUBROUTINE PDISP (ID,RG,RGST,R,NOD,IDIRN,NCUR,FAC,ARTM,KL,
     1                  NODE,NTFND,NDOF,NPDIS,NTAPE)
C
C     SUBROUTINE
C     1. TO READ PRESCRIBED DISPLACEMENTS DATA
C     2. TO CALCULATE THE DISPLACEMENT VECTORS CORRESPONDING TO THESE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   V A R I A B L E S :                                             .
C .                                                                   .
C .   ID      = ARRAY OF BOUNDARY CONDITION CODES                     .
C .   RG      = INTERPOLATED VALUES OF TIME FUNCTIONS                 .
C .   R       = DISP VECTOR                                           .
C .   TIMV,RV = ABSCISSA AND ORDINATES OF TIME FUNCTIONS              .
C .   NOD     = NODAL POINTS TO WHICH DISPS ARE APPLIED               .
C .   NCUR    = TIME FUNCTION NUMBERS OF DISPS                        .
C .   IDIRN   = DIRECTION CODES OF DISPS                              .
C .   FAC     = MULTIPLIER OF DISPS                                   .
C .   ARTM    = ARRIVAL TIMES OF DISPS                                .
C .   KL      = INCREMENTS IN NODES FOR GENERATION                    .
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,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 /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /SKEW/ NSKEWS
      COMMON /MDFRDM/ IDOF(6)
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPCIS,NTEMP
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
C
      DIMENSION ID(NDOF,1),RG(NTFND,1),R(NPDIS),NOD(1),IDIRN(1),
     1          NCUR(1),FAC(1),ARTM(1),KL(1),RGST(1),NODE(1)
C
      IF (IDATWR.GT.1) GO TO 5
      IF (NSKEWS.LE.0) WRITE (6,2000)
      IF (NSKEWS.GT.0) WRITE (6,2100)
C
    5 L=1
      K=1
C
   10 READ (5,1000) NODM,IDIRNM,NCURM,FACM,ARTMM,KLM,IDEBUG
      IF (K.NE.L) GO TO 50
C
C     SAVE DISP INFORMATION
C
   20 NOD(K)=NODM
      IDIRN(K)=IDIRNM
      NCUR(K)=NCURM
      FAC(K)=FACM
      ARTM(K)=ARTMM
      KL(K)=KLM
C
      IF (KLM.EQ.0) GO TO 90
      IF (L.EQ.NPDIS) GO TO 99
C
      L=L + 1
      GO TO 10
C
C     GENERATE PRESCRIBED DISPLACEMENT INFORMATION
C
   50 KK=K
      NGNOD=(NODM - NOD(KK))/KL(KK)
      DFAC=(FACM - FAC(KK))/NGNOD
      DARTM=(ARTMM - ARTM(KK))/NGNOD
C
      NJ=NGNOD - 1
      IF (NJ.LE.0) GO TO 55
      DO 52 J=1,NJ
      K=K + 1
C
      NOD(K)=NOD(K - 1) + KL(KK)
      IDIRN(K)=IDIRN(KK)
      NCUR(K)=NCUR(KK)
      FAC(K)=FAC(K-1) + DFAC
      ARTM(K)=ARTM(K-1) + DARTM
      KL(K)=KL(KK)
      IF (K.LE.NPDIS) GO TO 52
      WRITE(6,3010)
      STOP
   52 CONTINUE
C
   55 K=K + 1
      L=K
      IF (L.LE.NPDIS) GO TO 20
      GO TO 99
C
   90 L=L + 1
      K=L
      IF (L.LE.NPDIS) GO TO 10
C
   99 CONTINUE
C
C     WRITE PRESCRIBED DISP INFORMATION
C
      DO 100 I=1,NPDIS
      IF (IDATWR.GT.1) GO TO 110
      WRITE (6,2010) NOD(I),IDIRN(I),NCUR(I),FAC(I),ARTM(I),KL(I)
C
C     ERROR TESTS
C
  110 IF (NOD(I).LE.NUMNP) GO TO 120
      WRITE(6,3020) I,NOD(I)
      STOP
C
  120 IF (NCUR(I).GE.1 .AND. NCUR(I).LE.NTFN) GO TO 130
      WRITE(6,3030) K,NCUR(K)
      STOP
C
  130 IF (ARTM(I).GE.0. .AND. ARTM(I).LE.TEND) GO TO 100
      WRITE (6,3040) I
C
  100 CONTINUE
C
      IF (NSTE.EQ.0)     RETURN
      IF (MODEX.EQ.0)    RETURN
C
C
      DO 160 L=1,NPDIS
      LI=IDIRN(L)
      LN=NOD(L)
      IF (IDOF(LI).EQ.1) GO TO 155
      LDOF=LI
      DO 150 I=1,LDOF
  150 IF (IDOF(I).EQ.1) LI = LI - 1
      II=ID(LI,LN)
      IF (II.GT.0) GO TO 160
  155 WRITE (6,3050) I,LN,LI
      STOP
  160 NOD(L)=II
C
C     ARRANGE PRESCRIBED DISPLACEMENTS IN ASCENDING ORDER
C
  170 IF (NPDIS.LT.2) GO TO 185
      IS=0
      DO 180 L=2,NPDIS
      IF (NOD(L).GE.NOD(L - 1)) GO TO 180
      IS=IS + 1
      NSAV=NOD(L)
      NOD(L)=NOD(L - 1)
      NOD(L - 1)=NSAV
      NSAV=NCUR(L)
      NCUR(L)=NCUR(L - 1)
      NCUR(L - 1)=NSAV
      RSAV=FAC(L)
      FAC(L)=FAC(L - 1)
      FAC(L - 1)=RSAV
      RSAV=ARTM(L)
      ARTM(L)=ARTM(L - 1)
      ARTM(L - 1)=RSAV
  180 CONTINUE
      IF (IS.GT.0) GO TO 170
C
  185 DO 190 I=1,NPDIS
  190 NODE(I)=NOD(I)
C
      IF (IDEBUG.EQ.5) WRITE (6,5500) (NODE(I),I=1,NPDIS)
C
      REWIND NTAPE
      DO 200 K=1,NSTE
C
      DO 210 I=1,NPDIS
  210 R(I)=0.
C
      DO 220 L=1,NPDIS
      ARTMT=ARTM(L)
      FACT=FAC(L)
      LC=NCUR(L)
      NSTEA=ARTMT/DT
      NSTEF=K - NSTEA
      IF (NSTEF.LE.0) GO TO 220
      AFACT=NSTEA - ARTMT/DT + 1.
C
      II=NOD(L)
      RGFR=RG(LC,NSTEF)
      IF (ARTMT.EQ.0.) GO TO 240
C
      RGFR=RGST(LC)*(1.0 - AFACT) + RGFR*AFACT
      IF (NSTEF.LE.1) GO TO 240
      RGFR=RG(LC,NSTEF-1)*(1.0 - AFACT) + RG(LC,NSTEF)*AFACT
  240 R(L)=R(L) + RGFR*FACT
  220 CONTINUE
C
      WRITE (NTAPE)R
      IF (IDEBUG.EQ.5) WRITE (6,6000) R
  200 CONTINUE
C
      RETURN
 1000 FORMAT (3I5,2F10.0,I5,5X,I5)
 2000 FORMAT (////51H P R E S C R I B E D   D I S P L A C E M E N T   D
     1 5HA T A //4X,
     1        53H NODE   DIRECTION   DISP CURVE   DISP CURVE MULTIPL   ,
     2        50H   ARRIVAL TIME   NODE GENERATION                    )
 2100 FORMAT (////51H P R E S C R I B E D   D I S P L A C E M E N T   D
     1 5HA T A //4X,
     1        38H PRESCRIBED DISPLLACEMENTS ARA ASSUMED    /
     2 56H TO BE GIVEN IN THE SKEW COORDINATE SYSTEM OF EACH NODE.///4X,
     3 53H NODE   DIRECTION   DISP CURVE   DISP CURVE MULTIPL  ,
     4 34H    ARRIVAL TIME   NODE GENERATION)
 2010 FORMAT (1H0,2X,I5,5X,I4,9X,I4,9X,E13.5,8X,E12.4,7X,I5)
 3010 FORMAT (83H **ERROR**  THE NUMBER OF PRESCRIBED DISPLACEMENTS INPU
     1T OR GENERATED EXCEED NPDIS. /,12X,19HSTOPPED IN (PDISP )      )
 3020 FORMAT (55H **ERROR,  NODAL POINT OF PRESCRIBED DISPLACEMENT IS NO
     1 35HT IN THE RANGE OF NODAL POINTS USED/14H DISPLACEMENT
     2 7HNUMBER=,I5,24H     NODAL POINT NUMBER=,I5  )
 3030 FORMAT (55H **ERROR,  TIME FUNCTION CURVE SPECIFIED FOR DISPLACEME
     1 21HNT HAS NOT BEEN INPUT/14H DISPLACEMENT
     2 7HNUMBER=,I5,26H     TIME FUNCTION NUMBER=,I5  )
 3040 FORMAT (44H **WARNING,  ARRIVAL TIME OF DISPLACEMENT NO ,I5,
     1 31H IS NOT WITHIN TIME OF SOLUTION  )
 3050 FORMAT (//53H **ERROR**,  DISPLACEMENTS CAN BE PRESCRIBED ONLY AT
     1 26HACTIVE DEGREES OF FREEDOM. /31H CHECK INPUT OR GENERATED PRESC
     2 21HRIBED DISPLCEMENT NO=,I5,/23H CORRESPONDING TO NODE=,I5,
     3 29H MASTER DEGREE OF FREEDOM NO=,I5  )
C
 5500 FORMAT (//48H EQUATION NUMBERS OF PRESCRIBED DISP. DOF ARE - ,
     1          (/,10(I5,7X))  )
 6000 FORMAT (10F12.5/)
C
      END
C *CDC* *DECK TFUNCT
C *UNI* )FOR,IS N.TFUNCT,R.TFUNCT
      SUBROUTINE TFUNCT (RG,RGST,TIMV,RV,IPNT,NTFN,NPTM)
C
C     SUBROUTINE TO CALCULATE TIME FUNCTION VALUES AT ALL TIME POINTS
C     THE TIME FUNCTION VALUES ARE STORED IN RG
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /ISUBST/ ISUB,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(6),NDOFS,NEQS,NWKS,MAXES,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
C
      DIMENSION RG(NTFN,1),TIMV(NPTM,1),RV(NPTM,1),IPNT(1),RGST(1)
C
      NT=13
      IF (NSUBST.GT.0) NT=15
      REWIND NT
      DO 100 L=1,NTFN
      READ  (NT) RGST(L),(RG(L,K),K=1,NSTE),NPTS,
     1           (RV(J,L),TIMV(J,L),J=1,NPTS)
      IPNT(L)=NPTS
  100 CONTINUE
C
      RETURN
C
      END
C *CDC* *DECK GRAVL
C *UNI* )FOR,IS N.GRAVL,R.GRAVL
      SUBROUTINE GRAVL (ID,RG,R,RMASS,RSDCOS,NODSYS,
     1                  NEQ,NDOF,NTFN,MODEX,NRLOAD,NWLOAD,NUMNP,IDOF)
C
C     SUBROUTINE TO CALCULATE GRAVITY LOADING FOR FIRST NSTEG STEPS
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SKEW/ NSKEWS
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /SOL/ NUMNPP,NNN,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
C
      DIMENSION ID(NDOF,1),RMASS(1),R(NEQ),RG(NTFN,1),FDIRGR(3)
      DIMENSION LMNODE(3),FRST(3),NODSYS(1),RSDCOS(9,1),IDOF(6)
C
      READ (5,1000) NCUR,FDIRGR,ACCGRA
      IF (IDATWR.LE.1) WRITE (6,2000) NCUR,FDIRGR,ACCGRA
      IF (NCUR.GE.1 .AND. NCUR.LE.NTFN) GO TO 5
      WRITE (6,3000) NCUR,NTFN
      STOP
C
    5 IF (NSTE.EQ.0) RETURN
      IF (MODEX.EQ.0) RETURN
C
C
      DO 10 I=1,3
   10 FDIRGR(I)=ACCGRA*FDIRGR(I)
C
C     READ LUMPED MASS INTO CORE
C
      BACKSPACE 11
      BACKSPACE 11
      READ (11) R
C
C
   25 DO 100 N=1,NUMNP
C
      DO 30 K=1,3
      LMNODE(K)=0
   30 CONTINUE
C
      J=0
      DO 60 I=1,NDOF
   50 J=J+1
      IF (IDOF(J).EQ.1) GO TO 50
      L=ID(I,N)
      IF (L.LE.0) GO TO 60
      IF (J.LE.3) GO TO 55
      RMASS(L)=0.
      GO TO 60
C
C     NODE N, DIRECTION J  HAS EQUATION NUMBER  L
C
   55 LMNODE(J)=L
      RMASS(L)=FDIRGR(J)*R(L)
   60 CONTINUE
C
      IF (NSKEWS.EQ.0) GO TO 100
      NRST=NODSYS(N)
      IF (NRST.EQ.0) GO TO 100
      K=0
      DO 70 I=1,3
      FRST(I)=0.
      DO 70 J=1,3
      K=K+1
      FRST(I)=FRST(I) + RSDCOS(K,NRST)*FDIRGR(J)
   70 CONTINUE
      DO 80 J=1,3
      L=LMNODE(J)
      IF (L.EQ.0) GO TO 80
      RMASS(L)=FRST(J)*R(L)
   80 CONTINUE
C
  100 CONTINUE
C
      REWIND NRLOAD
      REWIND NWLOAD
      DO 340 L=1,NSTE
      FACT=RG(NCUR,L)
      READ (NRLOAD) R
      DO 350 I=1,NEQ
  350 R(I)=R(I) + FACT*RMASS(I)
C
      WRITE (NWLOAD) R
C
  340 CONTINUE
C
      RETURN
 1000 FORMAT (I5,4F10.0)
 2000 FORMAT (////62H  M A S S   P R O P O R T I O N A L   L O A D I N G
     1   D A T A   //4X,
     2  44H NUMBER OF TIME FUNCTION FOR THIS LOADING  =,I5/4X,
     3  44H FRACTION OF LOADING INTO X DIRECTION      =,E12.4/4X,
     4  44H FRACTION OF LOADING INTO Y DIRECTION      =,E12.4/4X,
     5  44H FRACTION OF LOADING INTO Z DIRECTION      =,E12.4/4X,
     6  44H ACCELERATION CONSTANT                     =,E12.4/)
C
 3000 FORMAT (///19H *** ERROR IN INPUT, /5X,
     1           30HLOAD CURVE NUMBER OUT OF RANGE  /5X,
     2            5HNCUR=,I5,5X,5HNTFN=,I5  //)
C
      END
C *CDC* *DECK PLVEC2
C *UNI* )FOR,IS N.PLVEC2,R.PLVEC2
      SUBROUTINE PLVEC2 (R,VEC,Y,Z,THICK,PI,PJ,IELTYP,IDIRN,NODES)
C
C
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION VEC(1),H(3),G(2),HR(3),Y(3),Z(3)
C
C     PRESSURE INTERPOLATION FUNCTIONS (LINEAR AT MOST)
C
      G(1) = 0.5*(1.0+R)
      G(2) = 0.5*(1.0-R)
C
C
      IF(NODES.GT.2) GO TO 10
C
C     TWO NODE EDGE
C
      H(1) = G(1)
      H(2) = G(2)
C
      HR(1) = 0.5
      HR(2) =-0.5
C
      GO TO 20
C
C     THREE-NODE EDGE
C
   10 H(1) = 0.5*R*(1.0+R)
      H(2) =-0.5*R*(1.0-R)
      H(3) = 1.0-R*R
C
      HR(1)= 0.5+R
      HR(2) =-0.5+R
      HR(3)=-2.0*R
C
C     DIFFERENTIAL MULTIPLIER
C
C          1. PLANE SOLID
C
   20 X1 = THICK
C
      IF (IELTYP.GT.0) GO TO 40
C
C          2. AXISYMMETRIC SOLID
C
      X1 = 0.0
      DO 30 K=1,NODES
   30 X1 = X1 + Y(K)*H(K)
C
C     GLOBAL DERIVATIVES AT STATION *R*
C
   40 YR = 0.0
      ZR = 0.0
C
      DO 50 K=1,NODES
      YR = YR + HR(K)*Y(K)
   50 ZR = ZR + HR(K)*Z(K)
C
C     PRESSURE AT STATION *R*
C
      PRESS = G(1)*PI + G(2)*PJ
      X1    =  X1*PRESS
C
      G(1) = X1*ZR
      G(2) =-X1*YR
C
C     NODE FORCE CONTRIBUTION
C
      DO 60 K=1,NODES
      VEC(2*K-1) = G(1)* H(K)
      VEC(2*K  ) = G(2)* H(K)
      IF (IDIRN.EQ.2) VEC(2*K  ) = 0.
   60 IF (IDIRN.EQ.3) VEC(2*K-1) = 0.
C
      RETURN
C
      END
C *CDC* *DECK PLVEC3
C *UNI* )FOR,IS N.PLVEC3,R.PLVEC3
      SUBROUTINE PLVEC3 (NODES,XX,PLOAD,PRINT,IDIRN,NODEP,ICOR)
C
C     SUBROUTINE TO CALCULATE CONCENTRATED NODAL FORCES DUE TO
C     PRESSURE ON 3-D ELEMENT FACE AND SHELL ELEMENT
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /GAUSS/ XG(4,4),WGT(4,4),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
C
      DIMENSION NODES(16),XX(3,16),PLOAD(48)
      DIMENSION H(16),Q(2,16),XJ(2,3),A(3),PRINT(4)
      DIMENSION NDNUM(16),ICOEF(7),COEF(4)
C
      DATA NDNUM /5,12,6,11, 6,9,7,12, 7,10,8,9, 8,11,5,10/,
     1     ICOEF /2,1,2,4,2,1,2/,
     2     COEF /-.6666666666667D0,-.6666666666667D0,-.3333333333333D0,
     3           -.3333333333333D0/
C
C     SURFACE INTEGRATION LOOP
C
      LRU=3
      IF (NODEP.EQ.16) LRU=4
C
      DO 300 LR=1,LRU
      R=XG(LR,LRU)
C
      DO 300 LS=1,LRU
      S=XG(LS,LRU)
C
      WT=WGT(LR,LRU)*WGT(LS,LRU)
C
C     EVALUATE THE INTERPOLATION FUNCTIONS AND DERIVATIVES
C
      RM     = 1.0 - R
      SM     = 1.0 - S
      RP     = 1.0 + R
      SP     = 1.0 + S
      RR     = 1.0 - R*R
      SS     = 1.0 - S*S
      RP3    = 0.5625 + 1.6875*R
      SP3    = 0.5625 + 1.6875*S
      RM3    = 0.5625 - 1.6875*R
      SM3    = 0.5625 - 1.6875*S
C
C          1. CORNER NODES
C
      H(1)    = 0.25*RP*SP
      H(2)    = 0.25*RM*SP
      H(3)    = 0.25*RM*SM
      H(4)    = 0.25*RP*SM
C
      Q(1,1) = 0.25*    SP
      Q(1,2) =-0.25*    SP
      Q(1,3) =-0.25*    SM
      Q(1,4) = 0.25*    SM
C
      Q(2,1) = 0.25* RP
      Q(2,2) = 0.25* RM
      Q(2,3) =-0.25* RM
      Q(2,4) =-0.25* RP
C
C     LINEAR INTERPOLATION OF PRESSURE AT STATION *(R,S)*
C
      PRESS=0.
      DO 5 I=1,4
    5 PRESS=PRESS + PRINT(I)*H(I)
C
C
      DO 10 K=5,NODEP
      H(  K)  = 0.0
      Q(1,K)  = 0.0
   10 Q(2,K)  = 0.0
C
C          2. SIDE NODES
C
      IF(NODES(5).EQ.0) GO TO 16
      H(  5)  = 0.50* RR* SP
      Q(1,5)  =-      R * SP
      Q(2,5)  = 0.50* RR
C
   16 IF(NODES(6).EQ.0) GO TO 17
      H(  6)  = 0.50* RM* SS
      Q(1,6)  =-0.50*    SS
      Q(2,6)  =-     RM*S
C
   17 IF(NODES(7).EQ.0) GO TO 18
      H(  7)  = 0.50* RR* SM
      Q(1,7)  =-      R * SM
      Q(2,7)  =-0.50* RR
C
   18 IF(NODES(8).EQ.0) GO TO 20
      H(  8)  = 0.50* RP* SS
      Q(1,8)  = 0.50*     SS
      Q(2,8)  =-      RP* S
C
C            A. MODIFY CORNER NODE FUNCTIONS WITH SIDE NODE CORRECTIONS
C
C
   20 DO 30 I=1,4
C
      J        =I+4
      K        =I+3
      IF(I.EQ.1)
     *K       = 8
C
      H(  I) = H(  I) - 0.5* (H(  J) + H(  K))
      DO 25 L=1,2
   25 Q(L,I) = Q(L,I) - 0.5* (Q(L,J) + Q(L,K))
   30 CONTINUE
C
      IF (NODEP.GT.8) GO TO 38
      IF (ICOR.NE.2) GO TO 40
C
C     CORRECT THE INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     OF DEGENERATED 8-NODE SURFACE  FOR SPATIAL ISOTROPY
C
      DH2D=RR*SS
      H(2)=H(2) + 0.125*DH2D
      Q(1,2)=Q(1,2) - 0.25*R*SS
      Q(2,2)=Q(2,2) - 0.25*S*RR
      H(3)=H(3) + 0.125*DH2D
      Q(1,3)=Q(1,3) - 0.25*R*SS
      Q(2,3)=Q(2,3) - 0.25*S*RR
      H(6)=H(6) - 0.25*DH2D
      Q(1,6)=Q(1,6) + 0.5*R*SS
      Q(2,6)=Q(2,6) + 0.5*S*RR
C
      GO TO 40
C
C     ADDITIONAL INTERPOLATIONS FOR SHELL LOADING
C
   38 IF (NODES(9).EQ.0) GO TO 31
      H(9)  =RM3*H(5)
      Q(1,9)=RM3*Q(1,5) - 3.0*H(5)
      Q(2,9)=RM3*Q(2,5)
C
   31 IF (NODES(10).EQ.0) GO TO 32
      H(10)  =SM3*H(6)
      Q(1,10)=SM3*Q(1,6)
      Q(2,10)=SM3*Q(2,6) - 3.0*H(6)
C
   32 IF (NODES(11).EQ.0) GO TO 33
      H(11)  =RP3*H(7)
      Q(1,11)=RP3*Q(1,7) + 3.0*H(7)
      Q(2,11)=RP3*Q(2,7)
C
   33 IF (NODES(12).EQ.0) GO TO 34
      H(12)  =SP3*H(8)
      Q(1,12)=SP3*Q(1,8)
      Q(2,12)=SP3*Q(2,8) + 3.0*H(8)
C
   34 CONTINUE
C
C     MODIFICATION OF LINEAR AND QUADRATIC INTERPOLATION FUNCTIONS
C     DUE TO THE PRESENCE OF CUBIC SIDE NODES
C
      DO 35 I=9,12
      IF (NODES(I).EQ.0) GO TO 35
      II=I - 8
      JJ=II + 1
      IF (I.EQ.12) JJ=1
      KK=I - 4
      H(II)=H(II) - 0.25*H(KK) + H(I)/3.
      H(JJ)=H(JJ) + 0.125*H(KK) - H(I)/3.
      H(KK)=1.125*H(KK) - H(I)
      DO 37 L=1,2
      Q(L,II)=Q(L,II) - 0.25*Q(L,KK) + Q(L,I)/3.
      Q(L,JJ)=Q(L,JJ) + 0.125*Q(L,KK) - Q(L,I)/3.
   37 Q(L,KK)=1.125*Q(L,KK) - Q(L,I)
   35 CONTINUE
C
      IF (NODEP.GT.12) GO TO 39
      IF (ICOR.NE.3) GO TO 40
C
C     CORRECT THE INTERPOLATION FUNCTIONS AND THEIR DERIVATIVES
C     OF DEGENERATED 12-NODE SURFACE  FOR SPATIAL ISOTROPY
C
      RS1=3.*(-R+S-R*S)
      RS2=3.*(-R-S+R*S)
      RS3=3.*RM*SP
      RSA1=RS1-1.
      RSA5=RS1-5.
      RSB1=RS2-1.
      RSB5=RS2-5.
      RMF=0.0078125*RM
      SMF=0.0078125*SM
      SPF=0.0078125*SP
      RMM=9.*RM*RMF
      RMSS=9.*SS*RMF
      RMMS=RM*RMSS
      RSAF=RSA1*RSA5 + RS3*(RSA1+RSA5)
      RSBF=RSB1*RSB5 + 3.*RM*SM*(RSB1+RSB5)
C
      H(2)=RMF*SP*RSA1*RSA5
      Q(1,2)=-SPF*RSAF
      Q(2,2)= RMF*RSAF
C
      H(3)=RMF*SM*RSB1*RSB5
      Q(1,3)=-SMF*RSBF
      Q(2,3)=-RMF*RSBF
C
      H(6)=RSA1*RMMS
      Q(1,6)=-RMMS*(RS3+RSA1+RSA1)
      Q(2,6)= RMM*(RS3*SM - 2.*S*RSA1)
C
      H(10)=-RSA5*RMMS
      Q(1,10)= RMMS*(RS3 + RSA5 + RSA5)
      Q(2,10)=-RMM*(RS3*SM - 2.*S*RSA5)
C
      GO TO 40
C
C     FOR THE CASE OF ONE INTERNAL NODE ONLY
C
   39 IF (NODES(14).GT.0) GO TO 36
      IF (NODES(13).EQ.0) GO TO 40
      H(13)  =    RR*SS
      Q(1,13)=-2.0*R*SS
      Q(2,13)=-2.0*S*RR
C
C     MODIFICATION OF INTERPOLATION FUNCTIONS DUE TO THE INTERNAL NODE
C
      DO 41 I=1,4
      H(I)  =H(I)   + 0.25*H(13)
      H(I+4)=H(I+4) - 0.5*H(13)
      DO 41 J=1,2
      Q(J,I)  =Q(J,I)   + 0.25*Q(J,13)
      Q(J,I+4)=Q(J,I+4) - 0.5*Q(J,13)
   41 CONTINUE
      GO TO 40
C
C     FOR THE CASE OF CUBIC INTERNAL NODES
C
   36 RPF=-(2.0*R*RP3 - 1.6875*RR)*SS
      RMF=-(2.0*R*RM3 + 1.6875*RR)*SS
      SPF=-(2.0*S*SP3 - 1.6875*SS)*RR
      SMF=-(2.0*S*SM3 + 1.6875*SS)*RR
C
      H(13)  =RR*SS*RP3*SP3
      Q(1,13)=RPF*SP3
      Q(2,13)=RP3*SPF
C
      H(14)  =RR*SS*RM3*SP3
      Q(1,14)=RMF*SP3
      Q(2,14)=RM3*SPF
C
      H(15)  =RR*SS*RM3*SM3
      Q(1,15)=RMF*SM3
      Q(2,15)=RM3*SMF
C
      H(16)  =RR*SS*RP3*SM3
      Q(1,16)=RPF*SM3
      Q(2,16)=RP3*SMF
C
C     MODIFICATION OF INTERPOLATIONS DUE TO CUBIC INTERNAL NODES
C
      DO 42 IH=13,16
      IJ=4*(IH-13)
      IK=16-IH
      DO 42 K=1,4
      I1=NDNUM(IJ+K)
      CF=ICOEF(IK+K)/9.0
      H(K) =H(K)  +   CF*H(IH)
      H(I1)=H(I1) + COEF(K)*H(IH)
      DO 42 J=1,2
      Q(J,K)  =Q(J,K)  +   CF*Q(J,IH)
      Q(J,I1)=Q(J,I1) + COEF(K)*Q(J,IH)
   42 CONTINUE
C
C     COMPUTE (R,S) DERIVATIVES WITH RESPECT TO (X,Y,Z) COORDINATES
C
   40 DO 50 I=1,2
      DO 50 J=1,3
      X=0.0
C
      DO 55 K=1,NODEP
   55 X      = X + Q(I,K)* XX(J,K)
      XJ(I,J)= X
   50 CONTINUE
C
C     COMPUTE THE DIRECTION COSINES OF THE SURFACE NORMAL VECTOR
C     AT POINT (R,S) IN THE ELEMENT FACE
C
      A(1)    = XJ(1,2) * XJ(2,3) - XJ(1,3) * XJ(2,2)
      A(2)    = XJ(1,3) * XJ(2,1) - XJ(1,1) * XJ(2,3)
      A(3)    = XJ(1,1) * XJ(2,2) - XJ(1,2) * XJ(2,1)
      X       = 0.0
      DO 60 K=1,3
   60 X       = X + A(K)*A(K)
      X       = DSQRT(X)
C
      IF(X.GT.1.0D-6) GO TO 70
C
      WRITE (6,2000) R,S
      STOP
C
   70 X      = 1.0/X
      DO 80 K=1,3
   80 A(K)   = A(K)* X
C
C     COMPUTE THE AREA DIFFERENTIAL
C
      A1     = 0.0
      A2     = 0.0
      A3     = 0.0
      DO 90 K=1,3
      A1     = A1 + XJ(1,K)* XJ(1,K)
      A2     = A2 + XJ(1,K)* XJ(2,K)
      A3     = A3 + XJ(2,K)* XJ(2,K)
   90 CONTINUE
      X      = DSQRT(A1*A3 - A2*A2)
C
      FACTOR = WT* X* PRESS
C
C     ASSEMBLE THE NODE FORCE CONTRIBUTION
C
      DO 100 K=1,NODEP
C
      IF(NODES(K).EQ.0) GO TO 100
C
      X      = FACTOR* H(K)
      I1=1
      I2=3
      IF (IDIRN.EQ.0) GO TO 93
      I1=IDIRN
      I2=I1
   93 DO 95 I=I1,I2
      J=3*(K-1)+I
   95 PLOAD(J)=PLOAD(J)-A(I)*X
C
  100 CONTINUE
  300 CONTINUE
C
      RETURN
 2000 FORMAT (48H0***ERROR   UNDEFINED ELEMENT FACE NORMAL VECTOR, /
     1        12X,3HR =, F10.4 /
     2        12X,3HS =, F10.4 )
      END
C *CDC* *DECK PLVECP
C *UNI* )FOR,IS N.PLVECP,R.PLVECP
      SUBROUTINE PLVECP (NODES,XX,PLOAD,PRINT,IDIRN)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     SUBROUTINE TO CALCULATE EQUIVALENT NODAL FORCES DUE TO
C     PRESSURE LOADING ON A PLATE ELEMENT.
C
C
C     WHEN VALUES OF PRESSURE AT ALL THREE NODES ARE EQUAL, THIS
C     CALCULATION IS EQUIVALENT TO LUMPING OF FORCES.
C
      DIMENSION NODES(16),XX(3,16),PLOAD(48)
      DIMENSION PRINT(4)
      DIMENSION D(6), DN(3)
C
C     TO ESTABLISH A NORMAL VECTOR TO THE PLANE OF THE PLATE ELEMENT
C
C     MATRIX DN CONTAINS COMPONENTS OF THE NORMAL VECTOR
C     XMAG= (2)X(AREA OF THE PLATE ELEMENT)
C
      D(1)=XX(1,2) - XX(1,1)
      D(2)=XX(2,2) - XX(2,1)
      D(3)=XX(3,2) - XX(3,1)
      D(4)=XX(1,3) - XX(1,1)
      D(5)=XX(2,3) - XX(2,1)
      D(6)=XX(3,3) - XX(3,1)
      DN(1) = D(2)*D(6) - D(3)*D(5)
      DN(2) = D(3)*D(4) - D(1)*D(6)
      DN(3) = D(1)*D(5) - D(2)*D(4)
      XMAG = DN(1)*DN(1) + DN(2)*DN(2) + DN(3)*DN(3)
      XMAG = DSQRT(XMAG)
      DO 100 I=1,3
  100 DN(I) = DN(I)/XMAG
C
C     CALCULATION OF PRESSURE LOAD
C
      XMA=XMAG/24.0
      I1=1
      I2=3
      IF (IDIRN.EQ.0) GO TO 110
      I1=IDIRN
      I2=I1
  110 CONTINUE
      PTOTAL=PRINT(1) + PRINT(2) + PRINT(3)
      DO 120 J=1,3
      DO 120 I=I1,I2
      PLOAD(3*(J-1)+I) = -(PTOTAL+PRINT(J))*XMA*DN(I)
  120 CONTINUE
C
      RETURN
C
      END
C *CDC* *DECK TLOADS
C *UNI* )FOR,IS N.TLOADS,R.TLOADS
      SUBROUTINE TLOADS (R,TIMES,RV,IPNT,NODE,NCUR,FACTOR,
     1                   ARTIME,KL,NPTMA)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .   PROGRAM                                                         .
C .      . TO GENERATE NODAL TEMPERATURE TAPE FROM INPUT DATA CARDS   .
C .                                                                   .
C .   THIS SUBROUTINE IS CALLED ONLY IF                               .
C .   ITP96.EQ.2 - GENERATE NODAL TEMPERATURES FROM INPUT CARDS       .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP
      COMMON /TIMFN/ TEND,NTFN,NPTM
      COMMON /CONST/ DT,DTA,ACOEF(21),DTOD,IOPE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
C
      DIMENSION R(1),TIMES(NPTMA,1),RV(NPTMA,1),IPNT(1),
     1          NODE(1),NCUR(1),FACTOR(1),ARTIME(1),KL(1)
C
      DATA ITT /56/
C
C     POSITION TEMPERATURE TAPE
C
      READ (ITT) TIMIN,(R(K),K=1,NUMNP)
C
      IF (NTEMP.GT.0) GO TO 200
C
C     WHEN NTEMP.EQ.0 (AND ITP96.EQ.2),
C     GENERATE TAPE WITH TEMP=0. AT ALL NODES
C
      IF (NSTE.EQ.0) RETURN
      DO 310 I=1,NUMNP
  310 R(I)=0.
      DO 325 J=1,NSTE
      TIME=TSTART + DT*DBLE(FLOAT(J))
      WRITE (ITT) TIME,(R(K),K=1,NUMNP)
  325 CONTINUE
C
      REWIND 56
C
      RETURN
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .   READ INPUT DATA AND CHECK FOR ERRORS        .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
  200 IF (IDATWR.LE.1) WRITE (6,2000)
C
      ISTOP=0
      DO 250 K=1,NTEMP
C
      READ (5,1000) NODE(K),NCUR(K),FACTOR(K),ARTIME(K),KL(K),IBUG
C
      IF (NODE(K).GT.0 .AND. NODE(K).LE.NUMNP) GO TO 210
      ISTOP=ISTOP+1
      WRITE (6,2100) K,NODE(K),NUMNP
  210 IF (NCUR(K).GE.0 .AND. NCUR(K).LE.NTFN) GO TO 240
      ISTOP=ISTOP+1
      WRITE (6,2110) K,NODE(K),NCUR(K),NTFN
C
  240 IF (K.EQ.NTEMP) KL(K)=0
      IF (IDATWR.GT.1) GO TO 250
C
      WRITE (6,2010) NODE(K),NCUR(K),FACTOR(K),ARTIME(K),KL(K)
C
  250 CONTINUE
C
      IF (ISTOP.EQ.0) GO TO 260
      WRITE (6,2500)
      STOP
C
  260 DO 275 K=1,NTEMP
C
      IF (KL(K).EQ.0) GO TO 275
      NODIF=NODE(K+1)-NODE(K)
      IDIFF=NODIF/KL(K)
      IF (NODIF.EQ.(IDIFF*KL(K))) GO TO 275
C
      ISTOP=ISTOP+1
      WRITE (6,2120) K,NODE(K),NODE(K+1),KL(K)
C
  275 CONTINUE
C
      IF (ISTOP.EQ.0) GO TO 10
      WRITE (6,2500)
      STOP
C
C . . . . . . . . . . . . . . . . . . . . . . . . .
C .   GENERATE TAPE (ITT) USING TIME FUNCTIONS    .
C . . . . . . . . . . . . . . . . . . . . . . . . .
C
   10 IF (NSTE.EQ.0) RETURN
      IF (IBUG.EQ.0) GO TO 15
      WRITE (6,2600)
C
   15 TIME=TSTART
C
      DO 100 I=1,NSTE
      TIME=TIME + DT
C
C     INITIALIZE R VECTOR
C
      DO 20 J=1,NUMNP
   20 R(J)=0.
C
      DO 60 K=1,NTEMP
C
      LN=NODE(K)
      LC=NCUR(K)
      NPTS=IPNT(LC)
      FACT=FACTOR(K)
      ARTM=ARTIME(K)
      KGEN=KL(K)
C
C     FOR GENERATION, CALCULATE
C     INCREMENTAL VALUES DFACT AND DARTM
C
      IF (KGEN.EQ.0) GO TO 25
      IDIFF=(NODE(K+1)-NODE(K)) / KGEN
      DIFF=DBLE(FLOAT(IDIFF))
      DARTM=(ARTIME(K+1)-ARTIME(K))/DIFF
      DFACT=(FACTOR(K+1)-FACTOR(K))/DIFF
C
   25 TIM=TIME-ARTM
C
C     LC=0 IMPLIES STEP FUNCTION AT TIME=ARTM
C
      IF (TIM.LT.0.) GO TO 50
      IF (LC.GT.0) GO TO 30
      R(LN)=R(LN)+FACT
      GO TO 50
C
C     CALCULATE VALUE OF FUNCTION AT TIM
C
   30 IF (TIM.GE.TIMES(1,LC)) GO TO 35
      WRITE (6,2200) I,LN,LC,NPTS,TIME,ARTM,TIMES(1,LC),TIM
      STOP
C
   35 DO 40 J=2,NPTS
      IF (TIM.GT.TIMES(J,LC)+DT*1.D-5) GO TO 40
      JJ=J
      JI=JJ-1
      GO TO 42
   40 CONTINUE
      WRITE (6,2210) I,LN,LC,NPTS,TIME,ARTM,TIMES(NPTS,LC),TIM
      STOP
C
   42 SLOPE=(RV(JJ,LC)-RV(JI,LC)) / (TIMES(JJ,LC)-TIMES(JI,LC))
      VALUE=RV(JI,LC) + SLOPE * (TIM-TIMES(JI,LC))
      R(LN)=R(LN) + FACT*VALUE
C
   50 IF (KGEN.EQ.0) GO TO 60
C
C     G E N E R A T I O N -
C     LINEAR INCREMENT OF FACT AND ARTM IN NODE NUMBERS
C
      LN=LN+KGEN
      IF (LN.GE.NODE(K+1)) GO TO 60
      FACT=FACT + DFACT
      ARTM=ARTM + DARTM
      GO TO 25
C
   60 CONTINUE
C
      WRITE (ITT) TIME,(R(LL),LL=1,NUMNP)
C
      IF (IBUG.EQ.0) GO TO 100
      WRITE (6,2610) I,TIME
      WRITE (6,2620) (LL,R(LL),LL=1,NUMNP)
C
  100 CONTINUE
C
C
      REWIND ITT
C
      RETURN
C
 1000 FORMAT (2I5,2F10.0,2I5)
 2000 FORMAT (////44H N O D A L   T E M P E R A T U R E   D A T A//
     1        12X,4HTIME,9X,13HTIME FUNCTION,26X,4HNODE/
     1        5H NODE, 5X,8HFUNCTION,10X,10HMULTIPLIER,5X,
     2        12HARRIVAL TIME,6X,10HGENERATION/)
 2010 FORMAT (I5,I10,3X,E20.6,E17.6,6X,I6)
 2100 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TLOADS/
     2        38H WHILE READING NODAL TEMPERATURE CARDS//
     3        5X,14H CARD NUMBER =,I5/
     3        5X,14H NODE NUMBER =,I5/
     3        5X,34H NUMBER OF NODES ... (NUMNP) ... =,I5//
     4        40H NODE NUMBER MUST BE GT.0 AND LE.NUMNP .)
 2110 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TLOADS/
     2        38H WHILE READING NODAL TEMPERATURE CARDS//
     3        5X,14H CARD NUMBER =,I5/
     3        5X,14H NODE NUMBER =,I5/
     3        5X,14H CURVE NUMBER=,I5/
     3        5X,34H NUMBER OF CURVES ... (NTFN) ... =,I5//
     4        41H CURVE NUMBER MUST BE GE.0 AND LE.NTFN . )
 2120 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TLOADS/
     2        38H WHILE READING NODAL TEMPERATURE CARDS//
     3        5X,20H CARD NUMBER     K =,I5/
     4        5X,20H NODE (K)          =,I5/
     5        5X,20H NODE (K+1)        =,I5/
     6        5X,20H KL (K)            =,I5//
     7        21H FOR NODE GENERATION,/
     8        49H (NODE(K+1)-NODE(K)) MUST BE DIVISIBLE BY KL(K) .)
 2200 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TLOADS/
     2        51H WHILE GENERATING NODAL TEMPERATURES FOR TIMESTEP =I5//
     4        5X,16H NODE NUMBER   =,I5/
     5        5X,16H CURVE NUMBER  =,I5/
     5        5X,28H NUMBER OF POINTS IN CURVE =,I5/
     3        5X,16H SOLUTION TIME =,E14.6/
     3        5X,16H ARRIVAL  TIME =,E14.6//
     7        28H FIRST TIME VALUE IN CURVE =,E14.6/
     8        50H MUST BE LE. TIME FOR ENTERING CURVE (TIME-ARTM) =,
     9        E14.6//12H *** S T O P)
 2210 FORMAT (///28H *** I N P U T   E R R O R -//
     1        30H DETECTED BY SUBROUTINE TLOADS/
     2        51H WHILE GENERATING NODAL TEMPERATURES FOR TIMESTEP =I5//
     3        5X,16H NODE NUMBER   =,I5/
     5        5X,16H CURVE NUMBER  =,I5/
     6        5X,28H NUMBER OF POINTS IN CURVE =,I5/
     7        5X,16H SOLUTION TIME =,E14.6/
     8        5X,16H ARRIVAL  TIME =,E14.6//
     9        28H LAST  TIME VALUE IN CURVE =,E14.6/
     1        50H MUST BE GE. TIME FOR ENTERING CURVE (TIME-ARTM) =,
     9        E14.6//12H *** S T O P)
 2500 FORMAT (///12H *** S T O P)
 2600 FORMAT (1H1,29HG E N E R A T E D   N O D A L,
     1        26H   T E M P E R A T U R E S)
 2610 FORMAT (///14H STEP NUMBER =,I5/14H TIME        =,E12.6///
     1        5H NODE,5X,11HTEMPERATURE,3(9X,5H NODE,5X,11HTEMPERATURE)
     2        /)
 2620 FORMAT (I5,E16.6,8X,I5,E17.6,8X,I5,E17.6,8X,I5,E17.6)
C
      END
C *CDC* *DECK OVL200
C *CDC*      OVERLAY (ADINA,20,0)
C *CDC* *DECK FREQS
C *UNI* )FOR,IS  N.FREQS,  R.FREQS
C *CDC*      PROGRAM FREQS
      SUBROUTINE FREQS
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      TO FIND THE LOWEST FREQUENCIES AND ASSOCIATED                .
C .      MODE SHAPES OF LINEARIZED STRUCTURE                          .
C .                                                                   .
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 /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /DPR/ ITWO
      REAL A
      COMMON A(1)
C
      IF (IESTYP.EQ.0)
C *CDC*     1   CALL OVERLAY (5HADINA,20B,1B,6HRECALL)
     1    CALL MSECNT
      IF (IESTYP.EQ.1)
C *CDC*     1   CALL OVERLAY (5HADINA,20B,2B,6HRECALL)
     1    CALL MSUBSP
C
C     RESET NUMBER OF MODES USED IN MODE SUPERPOSITION IF NECESSARY
C
      IF (IMODES.EQ.0) GO TO 100
      IF (NMODES.LE.NFREQ) GO TO 100
      WRITE (6,2000)
      NMODES=NFREQ
C
C     INITIAL CONDITIONS ARE TAKEN BACK INTO CORE
C
  100 IF (MODEX.EQ.0) GO TO 599
      IF (IMODES.GT.0) GO TO 599
      NN=N2 + NEQ*ITWO - 1
      READ (8) (A(I),I=N2,NN)
      NN=N7 + NEQ*ITWO - 1
      READ (8) (A(I),I=N7,NN)
      NN=N8 + NEQ*ITWO - 1
      READ (8) (A(I),I=N8,NN)
      IF (NDISCE.GT.0)
     1  CALL CONDIS (A(N01),A(N02),A(N03),A(N2),A(N7),A(N8),NIDM,1)
      IF (ITEMPR.LE.1) GO TO 599
      BACKSPACE 56
      NN=N6B - 1
      READ (56) (A(I),I=N6A,NN)
C
  599 CONTINUE
C
      RETURN
C
 2000 FORMAT (1H1,//47H ***NOTE*** WE RESET THE NUMBER OF MODES USED   /
     1              47H IN THE MODE SUPERPOSITION (NMODES) TO THE      /
     2              37H NUMBER OF MODES ACTUALLY CALCULATED  )
      END
C *CDC* *DECK PNORM
C *UNI* )FOR,IS  N.PNORM,  R.PNORM
      SUBROUTINE PNORM (MAXA,NCOLBV,S,B,XM,IRBM,RBMSH,NEQ,ISTOH,
     1                  NBLOCK,NSTIF,NMASS,IMASS,ANORM,NFREQ)
C
C     FINDS A NORM OF THE MATRIX S
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION S(ISTOH),B(ISTOH),XM(1)
      INTEGER MAXA(1),NCOLBV(1)
C
      NEQL=1
      NEQR=0
      MLA=0
      SUM=0.
      SHIFT=0.
      NT=9
      REWIND NT
      REWIND NSTIF
      REWIND NMASS
      NMDOF=0
      IF (IMASS.EQ.2) GO TO 16
      READ (NMASS) (XM(I),I=1,NEQ)
      DO 8 I=1,NEQ
    8 IF (XM(I).GT.0.) NMDOF=NMDOF+1
C
   16 DO 20 NJ=1,NBLOCK
      NEQR=NEQR + NCOLBV(NJ)
      READ (NSTIF) S
      IF (IMASS.EQ.2) READ (NMASS) B
      IF (IRBM.GT.0) WRITE (NT) S
C
      DO 10 I=NEQL,NEQR
      II=MAXA(I) - MLA
      AA=S(II)
      IF (IMASS.EQ.1) GO TO 18
      IF (B(II).GT.0.) NMDOF=NMDOF+1
   18 IF (AA.GT.0.) GO TO 10
      WRITE (6,1000) I,AA
      STOP
   10 SUM=SUM + AA
C
      IF (RBMSH.LT.0. .OR. IRBM.EQ.0) GO TO 19
C
      IF (IMASS.EQ.2) GO TO 15
      DO 12 I=NEQL,NEQR
      II=MAXA(I) - MLA
      DUM=XM(I)/S(II)
      IF (DUM.GT.SHIFT) SHIFT=DUM
   12 CONTINUE
      GO TO 19
C
   15 DO 17 I=NEQL,NEQR
      II=MAXA(I) - MLA
      DUM=B(II)/S(II)
      IF (DUM.GT.SHIFT) SHIFT=DUM
   17 CONTINUE
C
   19 NEQL=NEQL + NCOLBV(NJ)
   20 MLA=MAXA(NEQL) - 1
C
      ANORM=(SUM/NEQ)*.000000001D0
C
      IF (NMDOF.GE.NFREQ) GO TO 21
      WRITE (6,3020) NMDOF,NFREQ
      STOP
C
   21 IF (IRBM.EQ.0) RETURN
C
C     APPLY SHIFT IF RIGID BODY MODES ARE PRESENT
C
      IF (RBMSH) 30,25,22
   22 WRITE (6,3000)
      STOP
   25 RBMSH=-0.001/SHIFT
      WRITE (6,2000) RBMSH
   30 NEQL=1
      NEQR=0
      MLA=0
      REWIND NT
      REWIND NSTIF
      REWIND NMASS
C
      DO 120 NJ=1,NBLOCK
      NEQR=NEQR + NCOLBV(NJ)
      READ (NT) S
      IF (IMASS.EQ.2) GO TO 104
C
      DO 106 I=NEQL,NEQR
      II=MAXA(I) - MLA
  106 S(II)=S(II) - RBMSH*XM(I)
      GO TO 102
C
  104 READ (NMASS) B
      DO 108 I=1,ISTOH
  108 S(I)=S(I) - RBMSH*B(I)
C
  102 WRITE (NSTIF) S
      NEQL=NEQL + NCOLBV(NJ)
  120 MLA=MAXA(NEQL) - 1
C
      RETURN
C
 1000 FORMAT (43H ***ERROR   NEG OR ZERO DIAGONAL ELEMENT A(,I4,4H) =  ,
     1        E11.4,21HBEFORE DECOMPOSITION   )
 2000 FORMAT (//32H RIGID BODY MODE SHIFT APPLIED =,E15.5)
 3000 FORMAT (//46H *** ERROR IN FREQUENCY CONTROL CARD INPUT ***,/,
     1       54H THE VALUE FOR RIGID BODY SHIFT INPUT MUST BE NEGATIVE )
 3020 FORMAT (//30H *** STOP ***   ERROR IN INPUT  /
     1          42H NUMBER OF MASS DEGREES OF FREEDOM IS LESS   ,
     2          42H THAN NUMBER OF FREQUENCIES REQUESTED.     //
     2          24H NUMBER OF MASS D.O.F. =,I5/
     3          34H NUMBER OF FREQUENCIES REQUESTED =,I5//)
C
      END
C *CDC* *DECK BANDET
C *UNI* )FOR,IS  N.BANDET, R.BANDET
      SUBROUTINE BANDET (A,B,XM,V,D,MAXA,NCOLBV,ICOPL,NEQ,ISTOH,NBLOCK,
     1 RA,NSCH,IMASS,FDET,IDET,KKK)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /RQSHF/ IRQS
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /RHSV/ NVEC
C
      DIMENSION A(ISTOH),B(ISTOH),V(NEQ,1),D(1),XM(1)
      INTEGER MAXA(1),NCOLBV(1),ICOPL(1)
C
      NR=NEQ-1
      KHBB=0
      IF (IESTYP.EQ.0) NVEC=1
      IF (KKK-2) 10,690,780
C
   10 TOL=10.**10
      RTOL=0.00001
      NTF=3
      IS=1
      BSCALE=2.**(-80)
      USCALE=2.**(80)
      NSCH=0
      FDET=1.
      IDET=0
   50 NEQL=1
      NEQR=0
      MLA=0
C
      REWIND NSTIF
      REWIND NMASS
C
C - - FACTORIZE  MATRIX  ( A - RA*B )  ( LOOP OVER ALL BLOCKS ) - -
C
      DO 600 NJ=1,NBLOCK
C
      READ (NSTIF) A
      NCOLB=NCOLBV(NJ)
C
      IF (RA.EQ.0.) GO TO 60
      IF (IMASS.EQ.1) GO TO 52
      READ (NMASS) B
      DO 54 I=1,ISTOH
   54 A(I)=A(I) - RA*B(I)
      GO TO 60
   52 NEQR=NEQR + NCOLB
      DO 80 I=NEQL,NEQR
      II=MAXA(I) - MLA
   80 A(II)=A(II) - RA*XM(I)
C
   60 MM=MAXA(KHBB+1) - 1
      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
      CALL READMS (NRED,B,ISTOH,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
      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
C
      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.
      DO 240 L=1,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 (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.
      DO 520 L=1,KK
  520 C=C + A(KI+L)*A(KLT+L)
      A(KLT)=A(KLT) - C
  480 K=K + 1
C
  440 K=KS
      E=0.
      DO 540 KK=KL,KU
      K=K - 1
      C=A(KK)/D(K)
      IF(DABS(C).LT.TOL) GO TO 530
      WRITE (6,2010) N,C
      GO TO 550
  530 E=E + C*A(KK)
  540 A(KK)=C
      A(KN)=A(KN) - E
C
  420 D(KS)=A(KN)
      IF (D(KS)) 400,545,400
  545 IF (RA.EQ.0.) GO TO 555
  550 IS=IS + 1
      IF (IS.LE.NTF) GO TO 560
  555 WRITE (6,2000) NTF,RA
      STOP
  560 RA=RA*(1. - RTOL)
      RTOL=RTOL*10.
      KHBB=0
      GO TO 50
C
  400 CONTINUE
C
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      IF (IRQS.LT.0) IRQS=0
      NREC10=NJ + IRQS
      CALL WRITMS (NRED,A,ISTOH,NREC10,-1)
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      KHBB=KHBB + NCOLB
      NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL) - 1
  600 CONTINUE
C
      IF (D(NEQ).NE.0.) GO TO 650
      AA=DABS(D(1))
      DO 630 I=2,NEQ
  630 AA=AA + DABS(D(I))
      D(NEQ)=-(AA/NR)*0.00000000000001D0
C
  650 DO 660 I=1,NEQ
      IF (D(I).LT.0.) NSCH=NSCH + 1
  660 CONTINUE
      IF (IESTYP.EQ.1) RETURN
C
      DO 670 I=1,NEQ
      FDET=FDET*D(I)
      IF (FDET.LT.USCALE .AND. FDET.GE.BSCALE) GO TO 670
      CALL RSCALE (FDET,IDET)
  670 CONTINUE
C
      RETURN
C
C - - FIND EIGENVECTORS ( LOOP OVER ALL BLOCKS ) - -
C
  690 DO 700 NJ=1,NBLOCK
      IF (NBLOCK.EQ.1 .AND. IRQS.GE.0) GO TO 710
C
C        * * * * *        R A N D O M  A C C E S S        * * *
C
      NREC10=NJ
      IF (IRQS.GT.0) NREC10=NREC10 + IRQS
      CALL READMS (NRED,A,ISTOH,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
      IF (IRQS.GE.0) GO TO 716
C
      DO 714 N=1,NCOLB
      KS=N + KHBB
      KL=MAXA(KS) - MM
  714 D(KS)=A(KL)
      IF (NJ.EQ.NBLOCK) IRQS=0
C
  716 DO 720 N=1,NCOLB
      KL=MAXA(N+KHBB) - MM + 1
      KU=MAXA(N+KHBB+1) - MM - 1
      IF (KU-KL) 720,730,730
  730 KS=N + KHBB
      DO 750 NV=1,NVEC
      K=KS
      C=0.
      DO 740 KK=KL,KU
      K=K - 1
  740 C=C + A(KK)*V(K,NV)
  750 V(KS,NV)=V(KS,NV) - C
  720 CONTINUE
      KHBB=KHBB + NCOLB
  700 CONTINUE
C
C     BACKSUBSTITUTE
C
  780 DO 790 N=1,NEQ
      DO 790 NV=1,NVEC
  790 V(N,NV)=V(N,NV)/D(N)
  795 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 + IRQS
      CALL READMS (NRED,A,ISTOH,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
      IF (KU-KL) 861,890,890
  890 KS=KHBB + N
      DO 900 NV=1,NVEC
      K=KS
      DO 900 KK=KL,KU
      K=K - 1
  900 V(K,NV)=V(K,NV) - A(KK)*V(KS,NV)
  861 N=N-1
  860 CONTINUE
      NBL=NBL - 1
  800 CONTINUE
C
      RETURN
 2000 FORMAT (37H0***ERROR   SOLUTION STOP IN *BANDET*, / 12X,
     1        1H(,I3,37H) TRIANGULAR FACTORIZATIONS ATTEMPTED, / 12X,
     2        16HCURRENT SHIFT = ,E20.14 / 1X)
 2010 FORMAT (//47H STOP - STURM SEQUENCE CHECK FAILED BECAUSE OF
     135HMULTIPLIER GROWTH FOR COLUMN NUMBER,I4,//12H MULTIPLIER=,E20.8)
      END
C *CDC* *DECK MLTPLY
C *UNI* )FOR,IS  N.MLTPLY, R.MLTPLY
      SUBROUTINE MLTPLY(A,B,C,MAXA,NEQ,NCOLBV,ISTOH,NBLOCK,NTAPE)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      . TO CALCULATE   A = A + B*C  , WHERE B  IS STORED IN       .
C .        COMPACTED FORM  ,  A  AND  C  ARE VECTORS                  .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      DIMENSION A(1),B(ISTOH),C(1)
      INTEGER MAXA(1),NCOLBV(1)
C
      REWIND NTAPE
      IREAD=0
      IF (IESTYP.EQ.1 .AND. NBLOCK.EQ.1) IREAD=1
      IF (NEQ.GT.1) GO TO 10
C
      IF (IREAD.EQ.0) READ (NTAPE) B
      A(1)=A(1) + B(1)*C(1)
      RETURN
C
   10 DO 99 I=1,NEQ
   99 A(I)=0.
      NEQL=1
      NEQR=0
      MLA=0
      DO 40 L=1,NBLOCK
      IF (IREAD.EQ.0) READ (NTAPE) B
      NEQR=NEQR+NCOLBV(L)
      DO 100 I=NEQL,NEQR
      KL=MAXA(I) - MLA
      KU=MAXA(I+1) - 1 - MLA
      II=I + 1
      CC=C(I)
      DO 100 KK=KL,KU
      II=II - 1
  100 A(II)=A(II) + B(KK)*CC
      DO 200 I=NEQL,NEQR
      KL=MAXA(I) + 1 - MLA
      KU=MAXA(I+1) - 1 - MLA
      IF(KU-KL) 200,210,210
  210 II=I
      AA=0.
      DO 220 KK=KL,KU
      II=II - 1
  220 AA=AA + B(KK)*C(II)
      A(I)=A(I) + AA
  200 CONTINUE
C
      NEQL=NEQL + NCOLBV(L)
      MLA=MAXA(NEQL) - 1
   40 CONTINUE
C
      RETURN
      END
C *CDC* *DECK RSCALE
C *UNI* )FOR,IS  N.RSCALE, R.RSCALE
      SUBROUTINE RSCALE (FNUM,IEXP)
      IMPLICIT REAL*8 (A-H,O-Z)
      BSCALE=2.**(-80)
      USCALE=2.**80
      IPOWER=80
   10 IF (DABS(FNUM).LT.USCALE) GO TO 20
      FNUM=FNUM*BSCALE
      IEXP=IEXP + IPOWER
      GO TO 10
   20 IF (DABS(FNUM).GE.BSCALE) GO TO 30
      FNUM=FNUM*USCALE
      IEXP=IEXP-IPOWER
      GO TO 10
   30 CONTINUE
      RETURN
      END
C *CDC* *DECK WRFREQ
C *UNI* )FOR,IS  N.WRFREQ, R.WRFREQ
      SUBROUTINE WRFREQ (AA,NFREQ,RBMSH)
C
C     SUBROUTINE TO READ AND WRITE FREQUENCIES
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AA(1)
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
C
      BACKSPACE NT
      READ(NT) (AA(I),I=1,NFREQ)
      IF (RBMSH.EQ.0.) GO TO 100
      DO 200 I=1,NFREQ
      AA(I)=AA(I) + RBMSH
  200 IF (AA(I).LE.0.) AA(I)=1.D-10
  100 DO 300 I=1,NFREQ
  300 AA(I)=DSQRT(AA(I))
C
      WRITE(6,2010)
      PI=4.*DATAN(1.D0)
      DO 500 I=1,NFREQ
      ACIRC=AA(I)/(2.*PI)
      APERD=1./ACIRC
  500 WRITE(6,2000) I,AA(I),ACIRC,APERD
C
      RETURN
 2000 FORMAT (9X,I5,24X,E11.4,15X,E11.4,15X,E11.4)
 2010 FORMAT (1H1,// 24H   F R E Q U E N C I E S   //  2X,
     121H    FREQUENCY NUMBER   ,10X,20H FREQUENCY (RAD/SEC) ,4X,
     224H  FREQUENCY (CYCLES/SEC),8X,16HPERIOD (SECONDS)  / )
      END
C *CDC* *DECK WRMOD
C *UNI* )FOR,IS  N.WRMOD,  R.WRMOD
      SUBROUTINE WRMOD (FRQ,PHI,ID,NUMNP,NDOF,NEQ,NFREQ,NMODE)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /MDFRDM/ IDOF(6)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,LUNODE,LU1,LU2,LU3,JDC,JVC,JAC
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DISCON/ NDISCE,NIDM
      REAL A
      COMMON A(1)
C
      DIMENSION FRQ(1),PHI(1),ID(NDOF,1)
      DIMENSION D(6)
      DATA RECLB1/8HFREQENCY/,RECLB2/8HEIGNVCTR/
C
C     PRINT EIGENVECTOR FOR EACH MODE
C
C
C***  DATA PORTHOLE (START)
C
      RECLAB=RECLB1
      IF (JNPORT.NE.0)
     1 WRITE(LUNODE) RECLAB,NFREQ,NMODE,NEQ,(FRQ(I),I=1,NFREQ)
      RECLAB=RECLB2
C
C***  DATA PORTHOLE (END)
C
      REWIND NT
      DO 200 IM=1,NFREQ
      READ(NT) (PHI(I),I=1,NEQ)
C
      IF (NDISCE.GT.0)
     1  CALL CONDIS (A(N01),A(N02),A(N03),PHI,PHI,PHI,NIDM,0)
      NEQT = NEQ + NDISCE
C
C***  DATA PORTHOLE (START)
C
      IF (JNPORT.NE.0)
     1 WRITE (LUNODE) RECLAB,(PHI(I),I=1,NEQT)
C
C***  DATA PORTHOLE (END)
C
      IF (IM.GT.NMODE) GO TO 200
      WRITE (6,2000) IM,FRQ(IM)
C
      DO 100 II=1,NUMNP
      DO 110 I=1,6
  110 D(I)=0.
      IL=1
      DO 120 I=1,6
      IF (IDOF(I) .EQ. 1) GO TO 120
      KK=ID(IL,II)
      IF (KK) 130,150,140
  130 KK=NEQ - KK
  140 D(I)=PHI(KK)
  150 IL=IL + 1
  120 CONTINUE
  100 WRITE(6,2010) II,D
  200 CONTINUE
      RETURN
C
 2000 FORMAT (///29H   M O D E  S H A P E  N O .  I3,
     1       55X,14H( FREQUENCY =  ,E11.4, 2H ) //
     2       9H    NODE 12X 14HX-DISPLACEMENT 4X 14HY-DISPLACEMENT 4X
     3       14HZ-DISPLACEMENT 8X 10HX-ROTATION 8X 10HY-ROTATION
     4       8X 10HZ-ROTATION  /)
 2010 FORMAT (2X,I5,8X,6E18.6)
C
      END
C *CDC* *DECK OVL201
C *CDC*      OVERLAY (ADINA,20,1)
C *CDC* *DECK MSECNT
C *CDC*      PROGRAM MSECNT
C *UNI* )FOR,IS N.MSECNT, R.MSECNT
      SUBROUTINE MSECNT
C
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .      TO FIND THE LOWEST FREQUENCIES AND ASSOCIATED                .
C .      MODE SHAPES OF LINEARIZED STRUCTURE                          .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /DPR/ ITWO
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON/FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON/ADDB/NEQL,NEQR,MLA,NBLOCK
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /MPRNT/ IOUTPT,ISTPRT
      COMMON /ITELM/ NITEM,NITEMM
      COMMON A(1)
      REAL A
C
C
      NC=NFREQ + 3
      M3=N2 + ISTOH*ITWO
      M4=M3 + ISTOH*ITWO
      IF (IMASS.EQ.1 .AND. NBLOCK.EQ.1) M4=M3
C
      READ (5,1000) NITEMM
      IF (NITEMM.EQ.0) NITEMM=60
      NITEM=2*NITEMM/3
      IF (IDATWR.LE.1) WRITE (6,2000) NITEMM
      IF (MODEX.EQ.0) GO TO 300
      NSTIF=4
      IF (KLIN.GT.0) NSTIF=12
      NRED=10
      NMASS=11
      NT=9
C
C     FIND PSEUDONORM OF STIFFNESS MATRIX AND APPLY SHIFT, IF SPECIFIED
C
      CALL PNORM (A(N1),A(N1A),A(N2),A(M3),A(M4),IRBM,RBMSH,NEQ,ISTOH,
     1            NBLOCK,NSTIF,NMASS,IMASS,ANORM,NFREQ)
C
C     CALCULATE NEW ARRAY ADDRESSES
C
      COFQ2=COFQ*COFQ - RBMSH
  300 M5=M4 + NEQ*ITWO
      IF (IMASS.EQ.2) M5=M4
      M6=M5 + NEQ*ITWO
      M7=M6 + NEQ*ITWO
      M8=M7 + NEQ*ITWO
      M9=M8 + 6*NEQ*ITWO
      M10=M9 + NC*ITWO
      M11=M10 + NC*ITWO
      M12=M11 + NC*ITWO
      M13=M12 + NC*ITWO
      M14=M13 + NC + 1
      IF(ISTPRT.GT.0) WRITE(6,2010)
      CALL SIZE (M14)
      IF (MODEX.EQ.0) GO TO 599
C
      CALL SECANT (A(N1),A(N1A),A(N1B),A(N2),A(M3),A(M4),A(M5),A(M6),
     1 A(M7),A(M8),A(M9),A(M10),A(M11),A(M12),A(M13),NEQ,ISTOH,NFREQ,NC,
     2 NBLOCK,IMASS,IFPR,ANORM,COFQ2)
C
C     PRINT THE FREQUENCIES AND MODE SHAPES
C
      CALL WRFREQ (A(N2),NFREQ,RBMSH)
C
      M3=N2 + NFREQ*ITWO
      M4=M3 + (NEQ + NDISCE)*ITWO
      M5=M4 + NDOF*NUMNP
      NN=M5 - 1
      REWIND 8
      READ(8) (A(I),I=M4,NN)
C
      CALL WRMOD (A(N2),A(M3),A(M4),NUMNP,NDOF,NEQ,NFREQ,NMODE)
C
C
  599 CONTINUE
      RETURN
C
 1000 FORMAT (I5,E10.4,3I5,F10.0)
 2000 FORMAT (1H1,53HD E T E R M I N A N T   S E A R C H   S O L U T I O
     1 N   ///,40H MAX NUMBER OF ITERATIONS ALLOWED                   ,/
     255H       FOR EACH EIGENPAIR . . . . . . . . . .(NITEMM) =,I5//)
 2010 FORMAT (//50H0**STORAGE CHECK FOR FREQUENCIES CALCULATION        )
C
      END
C *CDC* *DECK SECANT
C *UNI* )FOR,IS  N.SECANT, R.SECANT
      SUBROUTINE SECANT (MAXA,NCOLBV,ICOPL,A,B,XM,D,V,W,WW,ROOT,TIM,
     1                   ERRVR,ERRVL,NITE,N,ISTOH,NROOT,NC,NBLOCK,
     2                   IMASS,IFPR,ANORM,COFQ)
C
C     PROGRAM TO CALCULATE SMALLEST EIGENVALUES AND CORRESPONDING
C     EIGENVECTORS OF THE PROBLEM
C                           A* V = LAMBDA* B* V
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(ISTOH),B(ISTOH),XM(1),V(1),D(1),W(1),WW(N,1),ROOT(1)
     1 ,TIM(1),ERRVL(1),ERRVR(1)
      INTEGER NITE(1),MAXA(1),NCOLBV(1),ICOPL(1)
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON/SHIFT/RR,RA,RB,RC,FDETR,FDETA,FDETB,FDETC,FFR,FFA,FFB,FFC,
     1 IDETR,IDETA,IDETB,IDETC,IFR,IFA,IFB,IFC
      COMMON /RQSHF/ IRQS
      COMMON /ITELM/ NITEM,NITEMM
C
C     FOLLOWING TOLERANCES ARE SET FOR 13 (OR MORE) DIGIT ARITHMETIC
      ACTOL=0.0001
      RCBTOL=0.00001
      RITOL=0.000001
      RQTOL=0.000000000001D0
C
C     THE FOLLOWING ARE ITERATION NUMBER TOLERANCES
C
      NTF=5
      IITEM=10
      NVM=6
      ETA=2.0
      NOV=0
      IRQS=0
      IK=2
      JR=1
      NSK=0
      REWIND NT
      REWIND NSTIF
      REWIND NMASS
C
C     FIND LOCATIONS FOR NEGATIVE ELEMENTS IN STARTING
C     ITERATION VECTORS
C
      NC1=NC + 1
      IF (IMASS.EQ.2) GO TO 8
      READ (NMASS) (XM(I),I=1,N)
    8 NEQL=1
      NEQR=0
      MLA=0
      NZM=0
      DO 6 NJ=1,NBLOCK
      NCOLB=NCOLBV(NJ)
      NEQR=NEQR + NCOLB
      READ (NSTIF) A
      IF (IMASS.EQ.2) READ (NMASS) B
      DO 1 I=NEQL,NEQR
      II=MAXA(I) - MLA
      AA=A(II)
      IF (AA.GT.0.) GO TO 4
      WRITE (6,1000) I,AA
      STOP
    4 IF (IMASS.EQ.2) GO TO 9
      V(I)=XM(I)/AA
      IF (XM(I) .EQ. 0.) NZM=NZM + 1
      GO TO 1
    9 V(I)=B(II)/AA
    1 CONTINUE
      IF (NJ.EQ.NBLOCK) GO TO 6
      NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL) - 1
    6 CONTINUE
C
      NNZM=N - NZM
      IF (NROOT .LE. NNZM) GO TO 40
      WRITE (6,1200) NROOT,NNZM
      STOP
C
   40 DO 2 J=3,NC1
      IMAX=0
      RMAX=0.
      DO 3 I=1,N
      IF (V(I).LT.RMAX) GO TO 3
      RMAX=V(I)
      IMAX=I
    3 CONTINUE
      NITE(J)=IMAX
    2 V(IMAX)=0.
C
C     CHECK FOR SINGLE DEGREE-OF-FREEDOM SYSTEM
C
      IF (N.GT.1) GO TO 5
      IF (IMASS.EQ.1) B(1)=XM(1)
      IF (B(1).GT.0) GO TO 7
      WRITE (6,1180)
      STOP
    7 ROOT(1)=A(1)/B(1)
      NSCH=1
      A(1)=1./DSQRT(B(1))
      WRITE(NT) A(1)
      ERRVL(1)=0.
      GO TO 950
C
    5 CALL SECOND(TIM1)
      RA=0.0
      RR=0.0
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RA,NSCH,
     1            IMASS,FDETA,IDETA,1)
      FFA=FDETA
      IFA=IDETA
      FFR=FFA
      IFR=IFA
      FDETR=FDETA
      IDETR=IDETA
C
C   CHECK FOR ZERO EIGENVALUE(S)
C
      N1=MAXA(N) - MLA
      IF(A(N1).GT.ANORM) GO TO 10
      WRITE (6,1009)
      STOP
C
C   FIND LOWER BOUND ON SMALLEST EIGENVALUE
C
   10 IF (IFPR.EQ.1)
     * WRITE(6,1010)
      IF (IMASS-1) 99,99,95
   95 DO 98 I=1,N
   98 V(I)=1.
      CALL MLTPLY (W,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 101
   99 DO 100 I=1,N
  100 W(I)=XM(I)
  101 RT=0.0
      IITE=0
  110 IITE=IITE+1
      DO 120 I=1,N
  120 V(I)=W(I)
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RA,NSCH,
     1            IMASS,FDETA,IDETA,2)
      RQT=0.0
      DO 130 I=1,N
  130 RQT=RQT+W(I)*V(I)
      IF (IMASS-1) 179,179,178
  178 CALL MLTPLY (W,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 181
  179 DO 180 I=1,N
  180 W(I)=XM(I)*V(I)
  181 RQB=0.0
      DO 140 I=1,N
  140 RQB=RQB+W(I)*V(I)
      RQ=RQT/RQB
      IF (IFPR.EQ.1)
     * WRITE (6,1004) RQ
      BS=DSQRT(RQB)
      TOL=DABS(RQ-RT)/RQ
      RT=RQ
      IF (TOL.LT.RCBTOL) GO TO 150
      DO 160 I=1,N
  160 W(I)=W(I)/BS
      IF (IITE.LT.IITEM) GO TO 110
C
  150 TEMP=100.*TOL
      IF(TEMP.GT.0.1) TEMP=0.1
      RB=RQ*(1.0-TEMP)
      IS=0
  230 CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RB,NSCH,
     1            IMASS,FDETB,IDETB,1)
      IF (IFPR.EQ.1)
     * WRITE (6,1020) RB,NSCH
      FFB=FDETB
      IFB=IDETB
      IF (NSCH.EQ.0) GO TO 300
      IS=IS+1
      IF (IS.LE.NTF) GO TO 240
      WRITE (6,1030) NTF
      STOP
  240 RB=RB/IK
      IK=IK*2
      GO TO 230
C
C
C     I T E R A T I O N  F O R  I N D I V I D U A L  E I G E N P A I R S
C
C
  300 IF (IFPR.EQ.1)
     * WRITE (6,1040)
      NITE(JR)=-1
      IF (IFPR.EQ.1)
     * WRITE (6,1050) JR,NITE(JR),RA,FDETA,FFA,ETA,IDETA,IFA
      NITE(JR)=0
      IF (IFPR.EQ.1)
     * WRITE (6,1050) JR,NITE(JR),RB,FDETB,FFB,ETA,IDETB,IFB
C
C   WE STOP WHEN WE HAVE THE REQUIRED NUMBER OF ROOTS SMALLER THAN RC AN
C   NOV=0
C
  310 IF (NSCH.GE.NROOT) GO TO 900
      IF (RB.GT.COFQ) GO TO 900
C
      I=IFA-IFB
      FFA=FFA*2.0**I
      IFA=IFB
      DIF=FFB-FFA
      IF (DIF.NE.0.0) GO TO 320
      WRITE (6,1060)
      GO TO 900
  320 DEL=FFB*(RB-RA)/DIF
      RC=RB-ETA*DEL
      IF(RC.GT.0.) GO TO 325
      WRITE(6,1065) RC
      STOP
  325 TOL=RCBTOL*RC
      IF (DABS(RC-RB).GT.TOL) GO TO 330
      IF (IFPR.EQ.1)
     * WRITE (6,1070)
      ROOT(JR)=RB
      GO TO 400
C
  330 CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RC,NSCH,
     1            IMASS,FDETC,IDETC,1)
      FFC=FDETC
      IFC=IDETC
      NITE(JR)=NITE(JR)+1
      IF (JR.EQ.1) GO TO 340
      JJ=JR-1
      DO 350 K=1,JJ
      FFC=FFC/(RC-ROOT(K))
  350 CALL RSCALE (FFC,IFC)
  340 IF (IFPR.EQ.1)
     * WRITE (6,1050) JR,NITE(JR),RC,FDETC,FFC,ETA,IDETC,IFC
C
C   IF WE HAVE MORE SIGNCHANGES THAN EIGENVALUES SMALLER THAN RC WE
C   START INVERSE ITERATION
C
      NES=0
      IF (JR.EQ.1) GO TO 380
      DO 360 I=1,JJ
  360 IF (ROOT(I).LT.RC) NES=NES+1
  380 NOV=NSCH-NES
      IF (NOV.EQ.0) GO TO 370
      IF (IFPR.EQ.1)
     * WRITE (6,1080) NOV
      ROOT(JR)=RC
      IF (NOV.GT.1) NSK=1
C
      GO TO 400
  370 RR=RA
      FFR=FFA
      IFR=IFA
      FDETR=FDETA
      IDETR=IDETA
      RA=RB
      FFA=FFB
      IFA=IFB
      FDETA=FDETB
      IDETA=IDETB
      RB=RC
      FFB=FFC
      IFB=IFC
      FDETB=FDETC
      IDETB=IDETC
C
C     WE RESET ETA IF WE CAN ACCELERATE THE SECANT ITERATION STILL MORE
C
      TOL=RB*ACTOL
      IF (DABS(RA-RB).LT.TOL) ETA=ETA*2
      IF (NITE(JR).LE.NITEM) GO TO 310
      WRITE (6,1015) JR,NITE(JR)
      GO TO 900
C
C   CHECK FOR STORAGE
C
  400 IF (JR.LE.NC) GO TO 405
      WRITE (6,1090)
      GO TO 900
C
C     INITIALIZE STARTING INVERSE ITERATION VECTOR
C
  405 NOR=JR-1
      IF (NOR.GT.NVM) NOR=NVM
      CALL SECOND (TIM3)
      IF (IFPR.EQ.1)
     * WRITE (6,1100) NOR
      IF (JR.EQ.1) GO TO 435
      DO 420 I=1,N
  420 V(I)=1.0
      I=NITE(JR+1)
      V(I)=-1.0
  410 IF (IMASS-1) 429,429,428
  428 CALL MLTPLY (W,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 431
  429 DO 430 I=1,N
  430 W(I)=XM(I)*V(I)
  431 RQB=0.
      DO 432 I=1,N
  432 RQB=RQB + W(I)*V(I)
      RT=0.
  435 IS=0
      GO TO 510
C
C     INVERSE ITERATION
C
  440 NITE(JR)=NITE(JR)+1
      DO 450 I=1,N
  450 V(I)=W(I)
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RC,NSCH,
     1            IMASS,FDETC,IDETC,2)
      IF (IS.EQ.1) GO TO 460
      RQT=0.0
      DO 470 I=1,N
  470 RQT=RQT+W(I)*V(I)
      IF (IMASS-1) 474,474,473
  473 CALL MLTPLY (W,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 476
  474 DO 475 I=1,N
  475 W(I)=XM(I)*V(I)
  476 RQB=0.0
      DO 480 I=1,N
  480 RQB=RQB+W(I)*V(I)
      RQ=RQT/RQB
      RT=ROOT(JR)+RQ
      IF (IFPR.EQ.1)
     * WRITE (6,1110) JR,NITE(JR),RT,RQ
      TOL=RT*RQTOL
      EIGDIF=DABS(RT - RTA)
      IF (EIGDIF.GT.TOL) GO TO 510
      IS=1
      GO TO 440
C
  510 RTA=RT
      AL2=0.
      IF (NOR.EQ.0) GO TO 545
      DO 520 K=1,NOR
      AL=0.0
      DO 530 I=1,N
  530 AL=AL + WW(I,K)*V(I)
      AL2=AL2 + AL*AL
      DO 540 I=1,N
  540 W(I)=W(I)-AL*WW(I,K)
  520 CONTINUE
  545 BS=DSQRT(RQB)
      DO 490 I=1,N
  490 W(I)=W(I)/BS
C
C     PERFORM RAYLEIGH QUOTIENT SHIFT IF CONVERGENCE IS SLOW
C
      IF (NITE(JR).LE.NITEM) GO TO 440
      IF (NITE(JR).GT.(NITEM+1)) GO TO 552
      TOL=RT*RITOL
      IF (EIGDIF.LT.TOL) GO TO 554
      WRITE (6,1015) JR,NITEM
      GO TO 900
  554 IF (IFPR.EQ.1)
     *WRITE (6,1014) JR
      IRQS=NBLOCK
C
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RT,NSCHT,
     1            IMASS,FDETT,IDETT,1)
      ROOT(JR)=RT
  552 IF (NITE(JR).LE.NITEMM) GO TO 440
      WRITE (6,1015) JR,NITE(JR)
      GO TO 900
C
  460 RQT=0.0
      ERRT=RQB
      DO 570 I=1,N
  570 RQT=RQT+V(I)*W(I)
      IF (IMASS-1) 559,559,564
  564 CALL MLTPLY (W,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 561
  559 DO 560 I=1,N
  560 W(I)=XM(I)*V(I)
  561 RQB=0.0
      DO 580 I=1,N
  580 RQB=RQB+V(I)*W(I)
C
C     OBTAIN ERROR BOUNDS -
C     THE BOUNDS DEPEND ON THE DISTANCE FROM THE ROOT AND CAN BE LARGE
C
      RQ=RQT/RQB
      ROOT(JR)=ROOT(JR)+RQ
      ERR=DSQRT(ERRT/RQB)
      ERRVL(JR)=ROOT(JR)-ERR
      ERRVR(JR)=ROOT(JR)+ERR
C
      BS=DSQRT(RQB)
      DO 590 I=1,N
      W(I)=W(I)/BS
  590 V(I)=V(I)/BS
      WRITE (NT) (V(I),I=1,N)
      JJ=JR
      IF (JJ.LE.NVM) GO TO 610
      DO 600 K=1,N
      DO 600 L=2,NVM
  600 WW(K,L-1)=WW(K,L)
      JJ=NVM
  610 DO 620 K=1,N
  620 WW(K,JJ)=W(K)
C
      CALL SECOND (TIM2)
      TIM3=TIM2-TIM3
      IF (IFPR.EQ.1)
     * WRITE (6,1120) TIM3
      TIM(JR)=TIM2-TIM1
      TIM1=TIM2
C
C     IF RAYLEIGH QUOTIENT SHIFT HAS BEEN PERFORMED RESET IRQS TO A
C     NEGATIVE NUMBER
C
      IF (IRQS.GT.0) IRQS=-IRQS
C
C
C     DECIDE STRATEGY FOR ITERATION TOWARDS NEXT ROOT
C
      CALL STRAT (A,B,XM,V,D,MAXA,NCOLBV,ICOPL,ROOT,NITE,N,ISTOH,
     1            NBLOCK,JR,NOV,NSK,NSCH,ETA,IMASS)
C
C
      IF(NOV.GT.0) GO TO 400
      GO TO 300
C
  900 NROOT=JR-1
      IF (NROOT.GT.0) GO TO 902
      WRITE (6,1180)
      STOP
  902 IF (IFPR.EQ.0) GO TO 905
      WRITE (6,1140)
      WRITE (6,1006) (NITE(J),J=1,NROOT)
      WRITE (6,1150)
      WRITE (6,1008) (TIM(J),J=1,NROOT)
      WRITE (6,1160)
      WRITE (6,1004) (ERRVL(J),J=1,NROOT)
      WRITE (6,1004) (ERRVR(J),J=1,NROOT)
C
C     CALCULATE PHYSICAL ERROR NORMS
C
  905 REWIND NT
      DO 904 L=1,NROOT
      RT=ROOT(L)
      READ (NT) (V(I),I=1,N)
      CALL MLTPLY (W,A,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NSTIF)
      VNORM=0.0
      DO 911 I=1,N
  911 VNORM=VNORM + W(I)*W(I)
      IF (IMASS-1) 907,907,903
  903 CALL MLTPLY (WW,B,V,MAXA,N,NCOLBV,ISTOH,NBLOCK,NMASS)
      DO 906 I=1,N
  906 W(I)=W(I) - RT*WW(I,1)
      GO TO 908
  907 DO 909 I=1,N
  909 W(I)=W(I) - RT*XM(I)*V(I)
  908 WNORM=0.0
      DO 910 I=1,N
  910 WNORM=WNORM + W(I)*W(I)
      VNORM=DSQRT(VNORM)
      WNORM=DSQRT(WNORM)
      ERRVL(L)=WNORM/VNORM
  904 CONTINUE
C
  950 WRITE (6,1170)
      NROOT=NSCH
      WRITE (6,1004) (ROOT(J),J=1,NROOT)
      WRITE (6,1190)
      WRITE (6,1004) (ERRVL(J),J=1,NROOT)
C
      WRITE (NT) (ROOT(I),I=1,NROOT)
C
      RETURN
C
 1000 FORMAT (43H ***ERROR   NEG OR ZERO DIAGONAL ELEMENT A(,I4,4H) =  ,
     1        E11.4,21HBEFORE DECOMPOSITION   )
 1004 FORMAT (1H0,6E20.12)
 1006 FORMAT (1H0,6I20)
 1008 FORMAT (1H0,6F20.2)
 1009 FORMAT (44H0***ERROR   SOLUTION TERMINATED IN *SECANT*  , /
     1        12X,25HRIGID BODY MODE(S) FOUND., / 1X)
 1010 FORMAT (51H1INVERSE ITERATION GIVES FOLLOWING APPROXIMATION TO,
     1        18H LOWEST EIGENVALUE, 1X)
 1014 FORMAT (///48H RAYLEIGH QUOTIENT SHIFT IS CARRIED OUT FOR ROOT,I3)
 1015 FORMAT (42H0***ERROR   PRE-MATURE EXIT FROM *SECANT*  , / 12X,
     1        37HITERATION ABANDONED FOR ROOT NUMBER =, I4 / 12X,
     2        37HNUMBER OF ITERATIONS PERFORMED      =, I4 / 1X)
 1020 FORMAT (5H0RB = E20.12,7H NSCH = I4)
 1030 FORMAT (38H0***ERROR   SOLUTION STOP IN *SECANT* , / 12X, 1H(,
     1        I3,48H) FACTORIZATIONS PERFORMED IN AN ATTEMPT TO FIND,
     2        32H LOWER BOUND ON FIRST EIGENVALUE, / 12X,
     3        16HCHECK THE MODEL., / 1X)
 1040 FORMAT (1H1,4X,4HROOT,4X,4HNITE,18X,2HRC,15X,12HDET (A-RC*B),15X,
     12HFF,13X,3HETA,3X,4HIDET,4X,2HIF)
 1050 FORMAT (1H0,4X,I4,4X,I4,8X,3E22.14,F7.2,2I6)
 1060 FORMAT (42H0THE DEFLATED POLYNOMIAL HAS NO MORE ROOTS  )
 1065 FORMAT (36H0***ERROR  SOLUTION STOP IN *SECANT* ,/ 10X,
     1        40HCALCULATED SHIFT IS NON-POSITIVE. SHIFT=, E20.11)
 1070 FORMAT (29H0(RC-RB) IS SMALLER THAN TOL )
 1080 FORMAT (16H0WE JUMPED OVER I4,16H UNKNOWN ROOT(S)  )
 1090 FORMAT (42H0***ERROR   PRE-MATURE EXIT FROM *SECANT*  ,
     1        34H CAUSED BY EITHER OF THE FOLLOWING, / 12X,
     2        22H(1) BAD MODEL DATA, OR, / 12X,
     3        52H(2) ROOT CLUSTER (I.E., NEAR EQUAL OR REPEATED EIGEN,
     4        36HVALUES) ENCOUNTERED AT CURRENT SHIFT, / 16X,
     5        25HCAUSING STORAGE OVER-FLOW, 1X)
 1100 FORMAT (1H0,34X,4HROOT,18X,2HRQ,18X,4HNOR=,I2)
 1110 FORMAT (1H0,4X,I4,4X,I4,8X,2E22.14)
 1120 FORMAT (20H0TIME FOR INV ITERN F5.2)
 1140 FORMAT (42H0NO OF ITERATIONS FOR EACH EIGENVALUE ARE   /)
 1150 FORMAT (30H0TIME USED FOR EACH EIGENVALUE /)
 1160 FORMAT (46H0FOLLOWING ARE ERROR BOUNDS ON THE EIGENVALUES /
     1        51H (THE BOUNDS DEPEND ON THE SHIFTING IN THE SOLUTION,
     2        28H AND CAN THEREFORE BE LARGE) )
 1170 FORMAT (1H1,22H E I G E N V A L U E S     )
 1180 FORMAT (38H0***ERROR   SOLUTION STOP IN "SECANT"   , / 12X,
     1        23HNO EIGENVALUES COMPUTED, / 1X)
 1190 FORMAT (///  40H THE FOLLOWING ARE PHYSICAL ERROR BOUNDS,
     1             20H ON THE EIGENVALUES )
 1200 FORMAT (///45H *** STOP, REQUESTED NUMBER OF ROOTS, NROOT =,I5,
     1 63H IS LARGER THAN THE NUMBER OF NON-ZERO MASS DEGREES OF FREEDOM
     2=,I5)
      END
C *CDC* *DECK STRAT
C *UNI* )FOR,IS  N.STRAT, R.STRAT
      SUBROUTINE STRAT (A,B,XM,V,D,MAXA,NCOLBV,ICOPL,ROOT,NITE,N,ISTOH,
     1                  NBLOCK,JR,NOV,NSK,NSCH,ETA,IMASS)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/SHIFT/RR,RA,RB,RC,FDETR,FDETA,FDETB,FDETC,FFR,FFA,FFB,FFC,
     1 IDETR,IDETA,IDETB,IDETC,IFR,IFA,IFB,IFC
      COMMON /RQSHF/ IRQS
      DIMENSION A(1),B(1),V(1),D(1),XM(1),ROOT(1)
      INTEGER MAXA(1),NCOLBV(1),ICOPL(1),NITE(1)
C
C   CASE1 NO ROOT JUMPING HAS OCCURED. THE CALCULATED ROOT HAS BEEN
C   APPROACHED FROM BELOW
C
      RTOL=0.0000000001D0
      TOL=RTOL*ROOT(JR)
      IF (NOV.GT.0) GO TO 700
      IF (DABS(ROOT(JR)-RB).GT.TOL) GO TO 710
      IF (RA.GT.0.0) GO TO 720
      RA=RB/2.
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RA,NSCH,
     1            IMASS,FDETA,IDETA,1)
      FFA=FDETA
      IFA=IDETA
  720 RB=RA
      FFB=FFA
      IFB=IFA
      FDETB=FDETA
      IDETB=IDETA
      RA=RR
      FFA=FFR
      IFA=IFR
      FDETA=FDETR
      IDETA=IDETR
      GO TO 710
C
C   CASE2 ROOT JUMPING HAS OCCURED. THE CALCULATED ROOT IS SMALLER THAN
C   THE CURRENT SHIFT AND IS A SIMPLE ROOT
C
  700 IF (ROOT(JR).GT.RC) NSK=1
      IF (NSK.EQ.1) GO TO 730
      IF (DABS(RC-ROOT(JR)).LT.TOL) GO TO 740
      IF (DABS(ROOT(JR)-RB).LT.TOL) GO TO 750
      RA=RB
      FFA=FFB
      IFA=IFB
      FDETA=FDETB
      IDETA=IDETB
  750 RB=RC
      FFB=FFC
      IFB=IFC
      FDETB=FDETC
      IDETB=IDETC
      GO TO 710
  740 IF (DABS(ROOT(JR)-RB).GT.TOL) GO TO 710
      IF (RA.GT.0.0) GO TO 760
      RA=RB/2.
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RA,NSCH,
     1            IMASS,FDETA,IDETA,1)
      FFA=FDETA
      IFA=IDETA
  760 RB=RA
      FFB=FFA
      IFB=IFA
      FDETB=FDETA
      IDETB=IDETA
      RA=RR
      FFA=FFR
      IFA=IFR
      FDETA=FDETR
      IDETA=IDETR
  710 FFA=FFA/(RA-ROOT(JR))
      CALL RSCALE (FFA,IFA)
      FFB=FFB/(RB-ROOT(JR))
      CALL RSCALE (FFB,IFB)
      JR = JR + 1
      NOV=0
      ETA=2.0
      RETURN
C
C   CASE3 ROOT JUMPING HAS OCCURED. THE CALCULATED ROOT IS A MULTIPLE
C   ROOT AND/OR IS LARGER THAN THE CURRENT SHIFT
C
  730 IF (RA.GT.0.0) GO TO 780
      RA=RB/2.
      CALL BANDET(A,B,XM,V,D,MAXA,NCOLBV,ICOPL,N,ISTOH,NBLOCK,RA,NSCH,
     1            IMASS,FDETA,IDETA,1)
      FFA=FDETA
      IFA=IDETA
  780 IF (DABS(ROOT(JR)-RB).GT.TOL) GO TO 770
      RB=RA
      FFB=FFA
      IFB=IFA
      FDETB=FDETA
      IDETB=IDETA
      RA=RR
      FFA=FFR
      IFA=IFR
      FDETA=FDETR
      IDETA=IDETR
  770 FFA=FFA/(RA-ROOT(JR))
      CALL RSCALE (FFA,IFA)
      FFB=FFB/(RB-ROOT(JR))
      CALL RSCALE (FFB,IFB)
      FFR=FFR/(RR-ROOT(JR))
      CALL RSCALE (FFR,IFR)
      IF (ROOT(JR).LE.RC) NOV=NOV-1
      JR=JR+1
      NITE(JR)=0
      ROOT(JR)=RC
      IF (NOV.GT.0) RETURN
      NSK=0
      ETA=2.0
      RETURN
      END
C *CDC* *DECK OVL202
C *CDC*       OVERLAY (ADINA,20,2)
C *CDC* *DECK MSUBSP
C *CDC*       PROGRAM MSUBSP
C *UNI )FOR,IS N.MSUBSP, R.MSUBSP
      SUBROUTINE MSUBSP
C
C     MAIN PROGRAM TO READ IN CONTROL PARAMETERS AND ALLOCATE STORAGE
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMSSP/ M3,M4,M5,M6,M7,M8,M9
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /JUNK/ IHED(18),MTOT,LPROG
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /DPR/ ITWO
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /TOLS/ RTOL,ALPHA,CTOL,ANORM,RCTOL
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
      COMMON /FAST/ SHIFT1,SHIFT2,IOVER,IRPC,NSTV,IINTER,JROLD,NSCH1,
     1              IACCN,NJUNK,ISVTYP
      COMMON /ITELMT/ NSMAX,NITEM,NITEMM,NOVM
      COMMON /TAPES/ IIN,IOUT
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      EQUIVALENCE (IA(1),A(1))
C
      IIN=5
      IOUT=6
      NWM=NWK
      IF (IMASS.EQ.1) NWM=NEQ
C
      NSTIF=4
      IF (KLIN.GT.0) NSTIF=12
      NT=9
      NRED=10
      NMASS=11
      NSHIFT=18
      NOVER=19
C
C     INPUT FREQUENCY CONTROL DATA
C
      READ (5,1000) NITEM,IFSS,IACCN,RTOL,ISVTYP,NSTV,
     1              IINTER,SHIFT1,SHIFT2,NREAD
      IF (NREAD.GT.0) GO TO 30
C
      M3=N2 + ISTOH*ITWO
      M4=M3
      IF (IMASS.EQ.2 .OR. NBLOCK.GT.1) M4=M3 + ISTOH*ITWO
      M5=M4
      IF (IMASS.EQ.1) M5=M4 + NEQ*ITWO
      GO TO 40
C
C     IF NREAD.GT.0, STIFFNESS, MASS MATRICES ARE READ FROM TAPE NREAD
C
   30 REWIND NSTIF
      REWIND NMASS
      REWIND NREAD
      READ (NREAD) NEQ,NWK,NWM
      NEQ1=NEQ + 1
      NBLOCK=1
      ISTOH=NWK
      N1A=N1 + NEQ1
      N1B=N1A + 1
      N1C=N1B + 1
      N1D=N1C
      N2=N1D + 2*NBLOCK + 1
      M2=N2
C
      IA(N1A)=NEQ
      IA(N1B)=1
      NBLOC1=2*NBLOCK + 1
      IA(N1D)=0
      IA(N1D + 1)=0
      IA(N1D + 2)=0
C
C     * * * * *    R A N D O M   A C C E S S   * * * * *
C
C     CALL STINDX (10,IA(N1D),NBLOC1,0)
C *IBM*     DEACTIVATE ABOVE CARD FOR IBM MACHINE
C
C     * * * * *    R A N D O M   A C C E S S   * * * * *
C
      M3=M2 + NWK*ITWO
      M4=M3
      IF (IMASS.EQ.2) M4=M3 + NWM*ITWO
      M5=M4
      IF (IMASS.EQ.1) M5=M4 + NWM*ITWO
C
      NN=N1A - 1
      READ (NREAD) (IA(I),I=N1,NN)
      NN=M3 - 1
      READ (NREAD) (A(I),I=M2,NN)
      WRITE (NSTIF) (A(I),I=M2,NN)
      NN=M5 - 1
      READ (NREAD) (A(I),I=M3,NN)
      WRITE (NMASS) (A(I),I=M3,NN)
C
   40 IF (IDATWR.LE.1)
     1WRITE (IOUT,2000) IHED,NEQ,NWK,NWM
      IF (MODEX.EQ.0) GO TO 45
C
C     FIND PSEUDONORM OF STIFFNESS MATRIX AND APPLY SHIFT, IF NECESSARY
C
      CALL PNORM (A(N1),A(N1A),A(N2),A(M3),A(M4),IRBM,RBMSH,NEQ,ISTOH,
     1            NBLOCK,NSTIF,NMASS,IMASS,ANORM,NFREQ)
C
   45 NP=MIN0(2*NFREQ,NFREQ + 8)
      IF (NQ.LT.NP) IACCN=1
      IF (NQ.GT.NEQ) NQ=NEQ
      IF (RTOL.EQ.0.) RTOL=1.D-6
      ALPHA=1.
      IOVER=1
      IRPC=0
      IF (IACCN.EQ.1) IRPC=1
      CTOL=0.33
      NSMAX=24
      IF (NITEM.EQ.0) NITEM=24
      NITEMM=NITEM
      COFQ2=COFQ*COFQ - RBMSH
      IF (SHIFT2.EQ.0.0) SHIFT2=COFQ
      SHIFT1=SHIFT1*SHIFT1
      IF (SHIFT1.GT.0.0) SHIFT1=SHIFT1 - RBMSH
      SHIFT2=SHIFT2*SHIFT2 - RBMSH
      NCM=NQ
      IF (NQ.LT.NP) NCM=MIN0(NFREQ + NQ/2 + 1,NFREQ + 8)
      IF (IINTER.GT.0) NCM=NQ + 50
      IF (NCM.GT.NEQ) NCM=NEQ
      NC=NQ
      IF (IDATWR.LE.1)
     1  WRITE (6,2100) NITEM,IFSS,IACCN,RTOL,ISVTYP,NSTV
      IF (IINTER.EQ.1) WRITE (6,2200) IINTER,SHIFT1,SHIFT2
      IF (RTOL.GT.1.D-6) WRITE (6,3000) RTOL
C
C     SET UP STORAGE LOCATIONS FOR THIS CASE
C
   70 NNC=NC*(NC + 1)/2
      M6=M5 + NNC*ITWO
      M7=M6 + NNC*ITWO
      M8=M7 + NC*NC*ITWO
      M9=M8 + NC*ITWO
      M10=M9 + NC*ITWO
      M11=M10 + NEQ*ITWO
      M12=M11 + NEQ*ITWO
      M13=M12 + NCM
      M14=M13 + NC*ITWO
      M15=M14 + NC*ITWO
      M16=M15 + NC*ITWO
      M17=M16 + NEQ*NC*ITWO
      M18=M17 + NCM*ITWO
      M19=M18 + NEQ*ITWO
      M20=M19 + NC
      CALL SIZE (M20)
C
      IF (MODEX.EQ.0) GO TO 599
C
  100 CALL SSPACE (A(N1),A(N1A),A(N1B),A(N2),A(M3),A(M4),A(M5),A(M6),
     1             A(M7),A(M8),A(M9),A(M10),A(M11),A(M12),A(M13),A(M14),
     2             A(M15),A(M16),A(M17),A(M18),A(M10),A(M11),A(M18),
     3             A(M19),NEQ,NCM,ISTOH,NBLOCK)
C
C     PRINT THE FREQUENCIES AND MODE SHAPES
C
      CALL WRFREQ (A(N2),NFREQ,RBMSH)
C
      IF (NREAD.GT.0) MODEX=0
      IF (NREAD.GT.0) GO TO 599
      M3=N2 + NFREQ*ITWO
      M4=M3 + (NEQ + NDISCE)*ITWO
      M5=M4 + NDOF*NUMNP
      NN=M5 - 1
      REWIND 8
      READ(8) (A(I),I=M4,NN)
C
      CALL WRMOD (A(N2),A(M3),A(M4),NUMNP,NDOF,NEQ,NFREQ,NMODE)
C
  599 CONTINUE
C
      RETURN
C
 1000 FORMAT (3I5,F10.0,3I5,2F10.0,I3,I2,I5,F10.0)
 2000 FORMAT (1H1,10X,35HS U B S P A C E   I T E R A T I O N,//1X,18A4//
     155H NUMBER OF EQUATIONS . . . . . . . . . . . . . .(NEQ) =,I8/1X,
     254HNUMBER OF ELEMENTS IN STIFFNESS MATRIX . . . . (NWA) =,I8/1X,
     354HNUMBER OF ELEMENTS IN MASS MATRIX . . . . . . .(NWB) =,I8//)
 2100 FORMAT (//32H FREQUENCY SOLUTION CONTROL DATA,//5X,
     155HMAX NUMBER OF SUBSPACE ITERATIONS ALLOWED . . (NITEM) =,I5 /5X,
     255H   EQ.0, SET TO 24                                        //5X,
     355HSTURM SEQUENCE CHECK CONTROL PARAMETER . . . . (IFSS) =,I5 /5X,
     455H   EQ.0, CHECK NOT PERFORMED                               /5X,
     555H   EQ.1, CHECK PERFORMED                                  //5X,
     655HFLAG FOR APPLYING ACCELERATION PROCEDURES . . (IACCN) =,I5/ 5X,
     755H   EQ.0, NO ACCELERATION                                   /5X,
     855H   EQ.1, SELF-ADAPTIVE SHIFTING AND OVERRELAXATION         /5X,
     955H         PROCEDURES WILL BE APPLIED, IF NECESSARY         //5X,
     A55HCONVERGENCE TOLERANCE ON EIGENVALUES . . . . . (RTOL) =,E15.5,
     B/5X,30H   EQ.0., SET TO 1.D-6                                //5X,
     155HFLAG TO GENERATE STARTING ITERATION VECTORS. (ISVTYP) =,I5 /5X,
     255H   EQ.0, CONVENTIONAL STARTING VECTORS GENERATED           /5X,
     355H   EQ.1, VECTORS GENERATED USING LANCZOS METHOD          //5X,
     C55HNUMBER OF USER PROVIDED STARTING VECTORS . . . (NSTV) =,I5 /5X,
     D55H   GT.0, NSTV STARTING VECTORS ARE READ FROM TAPE18           )
 2200 FORMAT (/5X,
     155HFLAG FOR INTERMEDIATE EIGENPAIRS CALCULATION (IINTER) =,I5 /5X,
     255H   EQ.0, NFREQ LOWEST EIGENVALUES ARE CALCULATED           /5X,
     355H   EQ.1, CALCULATE ALL EIGENPAIRS BETWEEN SHIFTS 1,2      //5X,
     455HLOWER LIMIT ON EIGENVALUES TO BE CALCULATED  (SHIFT1) =,E15.5//
     55X55HUPPER LIMIT ON EIGENVALUES TO BE CALCULATED  (SHIFT2) =E15.5/
     68X55HNOTE - SHIFT1 AND SHIFT2 ARE NOW IN (RAD/SEC)**2 AND    /
     78X40HADJUSTED FOR THE RIGID BODY MODE SHIFT   )
C
 3000 FORMAT (///,12H *** WARNING,/,
     1            27H SPECIFIED VALUE FOR RTOL =,E15.5,/,
     2            42H RECOMMENDED VALUE FOR RTOL = .LE. 1.D-06  //)
      END
C *CDC* *DECK SSPACE
C *UNI* )FOR,IS N.SSPACE, R.SSPACE
      SUBROUTINE SSPACE (MAXA,NCOLBV,ICOPL,A,B,XM,AR,BR,VEC,EIGV,D,
     1                   TT,W,NLOC,RTOLV,EVC1,EVC2,R,FREQ,WW,BUP,BLO,
     2                   BUPC,NSIT,NN,NCM,ISTOH,NBLOCK)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .        TO SOLVE FOR THE SMALLEST EIGENVALUES AND CORRESPONDING    .
C .        EIGENVECTORS IN THE GENERALIZED EIGENPROBLEM USING THE     .
C .        SUBSPACE ITERATION METHOD                                  .
C .                                                                   .
C .  - - INPUT VARIABLES - -                                          .
C .        MAXA(NNM) = VECTOR CONTAINING ADDRESSES OF DIAGONAL        .
C .                    ELEMENTS OF STIFFNESS MATRIX A                 .
C .        NCOLBV    = NUMBER OF COLUMNS PER BLOCK VECTOR             .
C .        ICOPL     = LEAST NUMBERED COUPLING BLOCK                  .
C .        A(NWK)    = STIFFNESS MATRIX IN COMPACTED FORM             .
C .        B(NWK)    = CONSISTENT MASS MATRIX IN COMPACTED FORM       .
C .        XM(NN)    = LUMPED MASS MATRIX                             .
C .        AR(NNC)   = WORKING MATRIX STORING PROJECTION OF K         .
C .        BR(NNC)   = WORKING MATRIX STORING PROJECTION OF M         .
C .        VEC(NC*NC)= WORKING ARRAY                                  .
C .        EIGV(NC)  = WORKING VECTOR                                 .
C .        D(NC)     = WORKING VECTOR                                 .
C .        TT(NN)    = WORKING VECTOR                                 .
C .        W(NN)     = D VECTOR OF LDLT FACTORS                       .
C .        NLOC(NCM) = VECTOR STORING DEGREES OF FREEDOM EXCITED IN   .
C .                    STARTING SUBSPACE                              .
C .        RTOLV(NC) = WORKING VECTOR                                 .
C .        EVC1(NC)  = WORKING VECTOR                                 .
C .        EVC2(NC)  = WORKING VECTOR                                 .
C .        R(NN,NC)  = EIGENVECTORS ON SOLUTION EXIT                  .
C .        FREQ(NCM) = FINAL EIGENVALUES                              .
C .        WW(NN)    = WORKING VECTOR                                 .
C .        BUP(NC)   = WORKING VECTOR                                 .
C .        BLO(NC)   = WORKING VECTOR                                 .
C .        BUPC(NC)  = WORKING VECTOR                                 .
C .        NSIT(NC)  = WORKING VECTOR                                 .
C .        NN        = ORDER OF STIFFNESS AND MASS MATRICES           .
C .        NWK       = NUMBER OF ELEMENTS BELOW SKYLINE OF            .
C .                    STIFFNESS MATRIX                               .
C .        NWM       = NUMBER OF ELEMENTS BELOW SKYLINE OF            .
C .                    MASS MATRIX                                    .
C .                      I. E. NWM=NWK FOR CONSISTENT MASS MATRIX     .
C .                            NWM=NN  FOR LUMPED MASS MATRIX         .
C .        NROOT     = NUMBER OF REQUIRED EIGENVALUES AND EIGENVECTORS.
C .        NQ        = NUMBER OF ITERATION VECTORS USED               .
C .        NCM       = MIN(NFREQ + NQ/2,NFREQ + 8)     (BUT NCM       .
C .                    CANNOT BE LARGER THAN THE NUMBER OF MASS       .
C .                    DEGREES OF FREEDOM)                            .
C .        IFSS      = FLAG FOR STURM SEQUENCE CHECK                  .
C .                      EQ.0  NO CHECK                               .
C .                      EQ.1  CHECK                                  .
C .        IFPR      = FLAG FOR PRINTING DURING ITERATION             .
C .                      EQ.0  NO PRINTING                            .
C .                      EQ.1  PRINT                                  .
C .                                                                   .
C .  - - OUTPUT - -                                                   .
C .        FREQ(NROOT) = EIGENVALUES                                  .
C .        R(NN,NROOT) = EIGENVECTORS                                 .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C     IMPLICIT REAL*8 (A-H,O-Z)
C     ABS(X)=DABS(X)
C     SQRT(X)=DSQRT(X)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .        THIS PROGRAM IS USED IN SINGLE PRECISION ARITHMETIC ON     .
C .        CDC EQUIPMENT AND DOUBLE PRECISION ARITHMETIC ON IBM       .
C .        OR UNIVAC MACHINES .ACTIVATE,DEACTIVATE OR ADJUST ABOVE    .
C .        CARDS FOR SINGLE OR DOUBLE PRECISION ARITHMETIC            .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MAL
      COMMON /EL/ IXY,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /TAPES/ IIN,IOUT
      COMMON /FAST/ SHIFT1,SHIFT2,IOVER,IRPC,NSTV,IINTER,JROLD,NSCH1,
     1              IACCN,NJUNK,ISVTYP
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
      COMMON /TOLS/ RTOL,ALPHA,CTOL,ANORM,RCTOL
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /ITELMT/ NSMAX,NITEM,NITEMM,NOVM
      COMMON /RQSHF/ IRQS
      COMMON /RHSV/ NVEC
C
      DIMENSION A(ISTOH),B(ISTOH),XM(1),AR(1),BR(1),VEC(1),EIGV(1),D(1),
     1          TT(1),W(1),RTOLV(1),EVC1(1),EVC2(1),R(NN,1),FREQ(1),
     2          WW(1),BUP(1),BLO(1),BUPC(1),TIM(10)
      INTEGER MAXA(1),NCOLBV(1),ICOPL(1),NLOC(1),NSIT(1)
C
      EQUIVALENCE (NROOT,NFREQ)
C
C     SET TOLERANCE FOR JACOBI ITERATION
C
      TOLJ=0.000000000001D0
C
C     INITIALIZATION
C
      ICONV=0
      IRQS=0
      NVEC=1
      NCEV=0
      JR=0
      JROLD=0
      RCTOL=0.0000000001D0
      IF (RTOL.LT.RCTOL) RCTOL=RTOL
      SHIFT=SHIFT1
      NC=NQ
      NNC=NC*(NC + 1)/2
      N1=NC + 1
      NC1=NC - 1
      DO 10 I=1,NC
      NSIT(I)=0
      EVC2(I)=0.
   10 D(I)=0.
      DO 15 I=1,10
   15 TIM(I)=0.
C
C     ESTABLISH STARTING ITERATION VECTORS
C
      REWIND NT
      REWIND NSTIF
      REWIND NMASS
      IF (IMASS.EQ.2 .AND. NBLOCK.EQ.1) READ (NMASS) B
      CALL SECOND (TIM1)
C
      ND=NN/NCM
      J=NN
      NEQL=1
      NEQR=0
      MLA=0
      DO 40 NJ=1,NBLOCK
      NCOLB=NCOLBV(NJ)
      NEQR=NEQR + NCOLB
      IF (NBLOCK.GT.1) READ (NSTIF) A
C
      IF (IMASS.EQ.2) GO TO 25
      DO 20 I=NEQL,NEQR
      II=MAXA(I) - MLA
      R(I,1)=XM(I)
      W(I)=XM(I)/A(II)
      IF (XM(I).EQ.0.) J=J - 1
   20 CONTINUE
      GO TO 35
   25 IF (NBLOCK.GT.1) READ (NMASS) B
      DO 30 I=NEQL,NEQR
      II=MAXA(I) - MLA
      W(I)=B(II)/A(II)
      R(I,1)=B(II)
   30 CONTINUE
C
   35 NEQL=NEQL + NCOLB
      MLA=MAXA(NEQL) - 1
   40 CONTINUE
      IF (NCM.LE.J .AND. NROOT.LE.J) GO TO 50
      WRITE (IOUT,2007) NCM,J
      STOP
C
C     CHECK FOR SINGLE DEGREE-OF-FREEDOM SYSTEM
C
   50 IF (NN.GT.1) GO TO 65
      IF (IMASS.EQ.1) B(1)=XM(1)
      IF (B(1).GT.0.) GO TO 62
      WRITE (IOUT,2008)
      STOP
   62 EIGV(1)=A(1)/B(1)
      JR=1
      NSCH=1
      A(1)=1./DSQRT(B(1))
      WRITE(NT) A(1)
      NEI=NSCH
      GO TO 1150
C
   65 IF (NCM.EQ.1) GO TO 95
      IF (NC.EQ.1) GO TO 69
      DO 68 J=2,NC
      DO 68 I=1,NN
   68 R(I,J)=0.
   69 L=NN - ND
      DO 90 J=2,NCM
      RT=0.
      DO 70 I=1,L
      IF (W(I).LT.RT) GO TO 70
      RT=W(I)
      IJ=I
   70 CONTINUE
      DO 80 I=L,NN
      IF (W(I).LE.RT) GO TO 80
      RT=W(I)
      IJ=I
   80 CONTINUE
      NLOC(J)=IJ
      W(IJ)=0.
      L=L-ND
      IF (J.LT.NC) R(IJ,J)=1.
   90 CONTINUE
C
      IF (IFPR.EQ.0) GO TO 93
      WRITE (IOUT,2009)
      WRITE (IOUT,2001) (NLOC(J),J=2,NCM)
   93 IF (NC.EQ.1) GO TO 95
C
C     A RANDOM VECTOR IS TAKEN AS THE LAST ITERATION VECTOR
C
C     RANDOM NUMBER XX(N+1)=FRACTIONAL PART OF (PI + XX(N))**5
C
      PI=3.141592654
      XX=0.5
      DO 92 K=1,NN
      XX=(PI + XX)**5
      IX=IDINT(XX)
      XX=XX - DBLE(FLOAT(IX))
   92 R(K,NC)=XX
C
C     READ NSTV STARTING VECTORS FROM TAPE18, IF PROVIDED
C
   95 IF (NSTV.LE.0) GO TO 120
      NV=NSTV
      IF (NV.GT.NC) NV=NC
      REWIND NSHIFT
      DO 110 J=1,NV
      READ (NSHIFT) (TT(I),I=1,NN)
      IF (IMASS.EQ.1) GO TO 100
      CALL MLTPLY (R(1,J),B,TT,MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 110
  100 DO 105 I=1,NN
  105 R(I,J)=XM(I)*TT(I)
  110 CONTINUE
C
  120 CALL SECOND (TIM2)
      TIM(1)=TIM2 - TIM1
C
C     FACTORIZE MATRIX A INTO (L)*(D)*(L(T))
C
      CALL BANDET(A,B,XM,TT,W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,SHIFT,
     1            NSCH,IMASS,FDETA,IDETA,1)
C
      CALL SECOND (TIM3)
      TIM(2)=TIM3 - TIM2
      NSCH1=NSCH
      IF (IFPR.NE.0 .AND. IINTER.GT.0)
     * WRITE (IOUT,2060) NSCH1
C
C     GENERATE STARTING VECTORS USING TRUNCATED LANCZOS ALGORITHM
C
      IF (ISVTYP.EQ.0) GO TO 130
      IF (NSTV.GE.NC1 .OR. NC.LE.2) GO TO 130
      M1=NSTV + 1
      DO 125 K=1,NN
  125 R(K,M1)=1.
      CALL STARTV (A,B,XM,TT,W,WW,R,MAXA,NCOLBV,ICOPL,NLOC,EVC1,
     1             M1,NC1,NN,ISTOH,NBLOCK,1)
      CALL SECOND (TIM4)
      TIM(1)=TIM(1) + TIM4 - TIM3
      TIM3=TIM4
C
C     FOR OUT-OF-CORE SOLUTION WRITE STARTING VECTORS ONTO TAPE NT
C
  130 IF (NBLOCK.EQ.1) GO TO 140
      REWIND NOVER
      DO 135 J=1,NC
  135 WRITE (NOVER) (R(K,J),K=1,NN)
      REWIND NOVER
  140 DO 150 J=1,NC
  150 NLOC(J)=0
C
C - - - S T A R T   O F   I T E R A T I O N   L O O P
C
      NSTEP=4
      NITE=0
      NLQ=0
      RLQ1=0.
  200 NITE=NITE + 1
      IF (IFPR.EQ.0) GO TO 202
      WRITE (IOUT,2010) NITE
C
C     P R O J E C T I O N   O F   A  M A T R I X
C
  202 CALL SECOND (TIM4)
      IF (IRPC.EQ.0) JR=0
      JJ=JR + 1
      IF (NBLOCK.EQ.1) GO TO 220
C
C     FOR OUT-OF-CORE SOLUTION BACKSUBSTITUTE ALL VECTORS SIMULTANEOUSLY
C
      NVEC=NC - JR
C
      CALL BANDET (A,B,XM,R(1,JJ),W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,
     1             SHIFT,NSCH,IMASS,FDETA,IDETA,2)
C
      NVEC=1
C
  220 DO 255 J=JJ,NC
      IF (NBLOCK.EQ.1) GO TO 225
      READ (NOVER) (TT(K),K=1,NN)
      GO TO 230
  225 DO 228 K=1,NN
  228 TT(K)=R(K,J)
C
      CALL BANDET (A,B,XM,R(1,J),W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,
     1             SHIFT,NSCH,IMASS,FDETA,IDETA,2)
C
  230 IJ=J
      DO 250 I=1,J
      ART=0.
      IF (I - JR) 238,238,242
  238 DO 240 K=1,NN
  240 ART=ART + R(K,J)*R(K,I)
      ART=ART*(EIGV(I) - SHIFT)
      GO TO 248
  242 DO 246 K=1,NN
  246 ART=ART + R(K,I)*TT(K)
  248 AR(IJ)=ART
  250 IJ=IJ + NC - I
  255 CONTINUE
C
C     P R O J E C T I O N   O F   B  M A T R I X
C
      JJ=JR + 1
      DO 310 J=JJ,NC
      IF (IMASS - 1) 275,275,272
  272 CALL MLTPLY (TT,B,R(1,J),MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 278
  275 DO 276 K=1,NN
  276 TT(K)=XM(K)*R(K,J)
C
  278 IJ=J
      DO 290 I=1,J
      BRT=0.
      IF (ICONV.GT.0) GO TO 279
  277 IF (I - J ) 283,279,279
  279 DO 280 K=1,NN
  280 BRT=BRT + R(K,I)*TT(K)
      GO TO 287
  283 DO 285 K=1,NN
  285 BRT=BRT + R(K,J)*R(K,I)
  287 BR(IJ)=BRT
  290 IJ=IJ + NC - I
      IF (ICONV.GT.0) GO TO 310
      DO 300 K=1,NN
  300 R(K,J)=TT(K)
  310 CONTINUE
      CALL SECOND (TIM5)
      TIM(3)=TIM(3) + TIM5 - TIM4
C
C     SOLVE FOR EIGENSYSTEM OF SUBSPACE OPERATORS
C
      IF (IFPR.NE.2) GO TO 430
      KKK=1
  400 WRITE (IOUT,2020)
      II=1
      DO 410 I=1,NC
      ITEMP=II+NC-I
      WRITE(IOUT,2005) (AR(J),J=II,ITEMP)
  410 II=II + N1 - I
      WRITE (IOUT,2030)
      II=1
      DO 420 I=1,NC
      ITEMP=II+NC-I
      WRITE(IOUT,2005) (BR(J),J=II,ITEMP)
  420 II=II + N1 - I
      IF (KKK - 1) 430,430,440
C
  430 CALL JACOBI (AR,BR,VEC,EIGV,TT,NC,NNC,TOLJ,SHIFT,NSMAX,IFPR)
      CALL SECOND (TIM6)
      TIM(4)=TIM(4) + TIM6-TIM5
C
      IF (IFPR.NE.2) GO TO 440
      WRITE (IOUT,2040)
      KKK=2
      GO TO 400
C
C     ARRANGE EIGENVALUES IN ASCENDING ORDER
C
  440 DO 445 I=1,NC
  445 EIGV(I)=EIGV(I) + SHIFT
      IF (NC.EQ.1) GO TO 465
C
  448 IS=0
      DO 460 I=1,NC1
      IF (EIGV(I + 1).GE.EIGV(I)) GO TO 460
      IS=IS+1
      EIGVT=EIGV(I + 1)
      EIGV(I + 1)=EIGV(I)
      EIGV(I)=EIGVT
      NCI=NC*I
      NCI1=NC*(I - 1)
      DO 450 K=1,NC
      RT=VEC(NCI + K)
      VEC(NCI + K)=VEC(NCI1 + K)
      VEC(NCI1 + K)=RT
  450 CONTINUE
  460 CONTINUE
      IF (IS.GT.0) GO TO 448
  465 IF (IFPR.EQ.0) GO TO 470
      WRITE (IOUT,2035)
      WRITE (IOUT,2006) (EIGV(I),I=1,NC)
C
C     CHECK TO SEE WHETHER ANY NEW ROOTS HAVE SUDDENLY APPEARED, IN THAT
C     CASE DECREASE JR. OTHERWISE CALCULATE HOW MANY MORE HAVE CONVERGED
C     ALSO MAKE SURE THAT CLUSTERED ROOTS ARE FROZEN TOGETHER
C
  470 JRN=0
      IF (NITE.EQ.1 .OR. IACCN.EQ.0 .OR. ICONV.GT.0) GO TO 490
      IF (NC.EQ.1 .OR. EIGV(1).LT.SHIFT1) GO TO 490
      DO 480 I=1,NC1
      DUM=DABS(EIGV(I) - D(I))/EIGV(I)
      IF (DUM.GT.RCTOL) GO TO 490
      IF (1.01*EIGV(I).LT.0.99*EIGV(I + 1)) JRN=I
  480 CONTINUE
  490 IF (JRN.LT.JR) JR=JRN
      IF (JRN.LE.JR) GO TO 500
      JJ=JR + 1
      DO 495 I=JJ,JRN
  495 NLOC(NCEV + I)=NITE - NSIT(I)
C
C     CALCULATE B TIMES APPROXIMATE EIGENVECTORS (ICONV.EQ.0)
C        OR     FINAL EIGENVECTOR APPROXIMATIONS (ICONV.GT.0)
C
  500 JJ=JR + 1
      DO 540 I=1,NN
      DO 510 J=1,NC
  510 TT(J)=R(I,J)
      DO 530 K=JJ,NC
      KK=NC*(K-1)
      RT=0.
      DO 520 L=1,NC
  520 RT=RT + TT(L)*VEC(KK+L)
  530 R(I,K)=RT
  540 CONTINUE
      IF (IFPR.NE.2) GO TO 542
      WRITE (IOUT,2045)
      DO 541 I=1,NC
      K1=I
      K2=NC*(NC - 1) + I
      WRITE (IOUT,2005) (VEC(J),J=K1,K2,NC)
  541 CONTINUE
C
C     UPDATE  JR, THE NUMBER OF CONVERGED ROOTS
C
  542 IF (ICONV.GT.0) GO TO 558
      JR=JRN
C
  558 CALL SECOND (TIM7)
      TIM(5)=TIM(5) + TIM7-TIM6
      IF (ICONV.GT.0) GO TO 1000
C
C     CHECK FOR CONVERGENCE OF EIGENVALUES,EIGENVECTORS
C
      DO 560 I=1,NC
      DIF=DABS(EIGV(I)-D(I))
  560 RTOLV(I)=DIF/EIGV(I)
      IF (IFPR.EQ.0) GO TO 570
      WRITE (IOUT,2050)
      WRITE (IOUT,2250) (RTOLV(I),I=1,NC)
C
C     ACCELERATE CONVERGENCE, IF NECESSARY AND IS POSSIBLE
C
  570 CALL SECOND (TIM8)
      NJUNK=0
      DO 590 J=1,NC
      IF (EIGV(J).GT.SHIFT1) GO TO 600
      NJUNK=J
  590 CONTINUE
  600 NJ=NJUNK + 1
      NR=NC - NJUNK
C
      CALL RAPID (EIGV(NJ),D(NJ),TT,W,EVC1(NJ),EVC2(NJ),RTOLV(NJ),
     1            R(1,NJ),R,FREQ,WW,XM,NLOC,NSIT(NJ),NN,NR)
C
      CALL SECOND (TIM9)
      TIM(6)=TIM(6) + TIM9-TIM8
C
  910 DO 920 I=1,NC
      EVC1(I)=EVC2(I)
      EVC2(I)=D(I)
  920 D(I)=EIGV(I)
      IF (JR.EQ.0) GO TO 960
      IF (ICONV.GT.0) GO TO 960
C
C     PRESET PROJECTION MATRICES CORRESPONDING TO CONVERGED EIGENVECTORS
C
      II=1
      DO 940 I=1,JR
      IJ=II
      AR(IJ)=EIGV(I) - SHIFT
      BR(IJ)=1.
      IJ=IJ + 1
      IF (I.EQ.JR) GO TO 940
      JJ=I + 1
      DO 930 J=JJ,JR
      AR(IJ)=0.
      BR(IJ)=0.
  930 IJ=IJ + 1
  940 II=II + N1 - I
C
  960 GO TO 200
C
C - - - E N D   O F   I T E R A T I O N   L O O P
C
 1000 CALL SECOND (TIM10)
      JR=NROOT
      J=0
      DO 1010 I=1,NC
      IF (EIGV(I).LT.SHIFT1) GO TO 1010
      J=J + 1
      FREQ(NCEV + J)=EIGV(I)
 1010 CONTINUE
C
      IF (NROOT.EQ.0) GO TO 1160
      REWIND NT
      IF (NCEV.EQ.0) GO TO 1030
      DO 1020 L=1,NCEV
 1020 READ (NT)
 1030 NR=NROOT - NCEV
      IF (NR.EQ.0) GO TO 1080
C
      J=0
      DO 1070 L=1,NC
      IF (EIGV(L).LT.SHIFT1) GO TO 1070
      J=J + 1
      IF (J.GT.NR) GO TO 1080
      IF (IMASS - 1) 1050,1050,1040
 1040 CALL MLTPLY ( W,B,R(1,L),MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 1060
 1050 DO 1055 I=1,NN
 1055 W(I)=XM(I)*R(I,L)
 1060 WRITE (NT) (R(I,L),I=1,NN),(W(I),I=1,NN)
 1070 CONTINUE
 1080 REWIND NT
C
C     CALCULATE AND PRINT ERROR NORMS
C
      REWIND NSTIF
      IF (NBLOCK.EQ.1) READ (NSTIF) A
      DO 1140 L=1,NROOT
      RT=FREQ(L)
      READ (NT) (WW(I),I=1,NN),(R(I,1),I=1,NN)
      CALL MLTPLY (TT,A,WW,MAXA,NN,NCOLBV,ISTOH,NBLOCK,NSTIF)
      VNORM=0.
      DO 1100 I=1,NN
 1100 VNORM=VNORM + TT(I)*TT(I)
      WNORM=0.
      DO 1120 I=1,NN
      TT(I)=TT(I) - RT*R(I,1)
 1120 WNORM=WNORM + TT(I)*TT(I)
      VNORM=DSQRT(VNORM)
      WNORM=DSQRT(WNORM)
      W(L)=WNORM/VNORM
 1140 CONTINUE
C
      WRITE (NT) (FREQ(I),I=1,NROOT)
C
      WRITE (IOUT,2100)
      WRITE (IOUT,2006) (FREQ(I),I=1,NROOT)
      WRITE (IOUT,2110) (NLOC(I),I=1,NROOT)
      WRITE(IOUT,2115)
      WRITE (IOUT,2006) (W(I),I=1,NROOT)
      IF (IFSS.EQ.0) GO TO 1160
C
C     APPLY STURM SEQUENCE CHECK
C
      NEI=NROOT
      NJUNK=0
      DO 1142 L=1,NC
      IF (EIGV(L).GT.SHIFT1) GO TO 1145
      NJUNK=L
 1142 CONTINUE
 1145 NJ=NJUNK + 1
      NCM=NCEV + NC - NJUNK
      CALL SCHECK (FREQ,RTOLV(NJ),BUP,BLO,BUPC,NLOC,NCM,NEI,RTOL,SHIFT)
C
      WRITE (IOUT,2120) SHIFT
C
C     SHIFT MATRIX A AND FACTORIZE SHIFTED MATRIX
C
      CALL BANDET(A,B,XM,TT,W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,SHIFT,
     1            NSCH,IMASS,FDETA,IDETA,1)
C
      NSCH=NSCH - NSCH1
 1150 WRITE (IOUT,2130) NSCH,SHIFT1,SHIFT,NEI
      IF (NSCH.EQ.NEI) GO TO 1160
      WRITE (IOUT,2132)
      IF (NSCH.GT.NEI) WRITE (IOUT,2140)
      STOP
 1160 CALL SECOND (TIM11)
      TIM(7)=TIM(7) + TIM11-TIM10
      TIM(10)=TIM11 - TIM1
      IF (IFPR.GT.0)
     1  WRITE (IOUT,2200) NITE,(TIM(I),I=1,7),TIM(10)
C
      RETURN
C
 2001 FORMAT (1H0,10I10)
 2005 FORMAT (12E11.4)
 2006 FORMAT (6E22.14)
 2007 FORMAT (///45H *** STOP, REQUESTED NUMBER OF ROOTS, NFREQ =,I5,
     1 63H IS LARGER THAN THE NUMBER OF NON-ZERO MASS DEGREES OF FREEDOM
     2=,I5)
 2008 FORMAT (38H0***ERROR   SOLUTION STOP IN "SSPACE"   , / 12X,
     1        23HNO EIGENVALUES COMPUTED, / 1X)
 2009 FORMAT ( ///,62H DEGREES OF FREEDOM EXCITED BY UNIT STARTING ITERA
     1TION VECTORS)
 2010 FORMAT (1H1,32HI T E R A T I O N   N U M B E R ,I4//)
 2020 FORMAT (28H0PROJECTION OF A (MATRIX AR) )
 2035 FORMAT (30H0EIGENVALUES OF AR-LAMBDA*BR  )
 2030 FORMAT (28H0PROJECTION OF B (MATRIX BR) )
 2040 FORMAT (40H0AR AND BR AFTER JACOBI DIAGONALIZATION  )
 2045 FORMAT (29H0Q MATRIX                       /)
 2050 FORMAT (43H0RELATIVE TOLERANCE REACHED ON EIGENVALUES  )
 2060 FORMAT (//,37H NUMBER OF EIGENVALUES BELOW SHIFT1 =,I5)
 2100 FORMAT (1H1,31H THE CALCULATED EIGENVALUES ARE )
 2110 FORMAT (///59H NUMBER OF SUBSPACE ITERATIONS PERFORMED FOR EACH EI
     1GENPAIR/,(1H0,20I5))
 2115 FORMAT (//1X,36HPRINT ERROR NORMS ON THE EIGENVALUES  )
 2120 FORMAT  (///,23H CHECK APPLIED AT SHIFT   E22.14)
 2130 FORMAT (/40H BASED ON STURM SEQUENCE CHECK THERE ARE,I4,
     1         29H EIGENVALUES BETWEEN SHIFT1 =,E15.5,12H AND SHIFT =,
     2         E15.5,//46H NUMBER OF EIGENVALUES CALCULATED BY THE PROGR
     3         21HAM IN THIS INTERVAL =,I4 //)
 2132 FORMAT (//50H *** REQUESTED FREQUENCIES NOT OBTAINED ***        /
     1          50H *** STOP OF SOLUTION ***                          //
     2          50H FAILURE OF SOLUTION ALGORITHM CAN BE DUE TO USE   /
     3          47H OF BAD MODEL OR INAPPROPRIATE USE OF SOLUTION
     4          15H PARAMETERS       //)
 2140 FORMAT (95H TO CALCULATE THE MISSING EIGENVALUES REPEAT THE SOLUTI
     1ON USING LARGER NUMBER OF TRIAL VECTORS.,/19H ALSO DECREASE RTOL )
 2200 FORMAT (1H1,///23H EIGENSOLUTION TIME LOG ,///1X,
     A51HNUMBER OF SUBSPACE ITERATIONS PERFORMED           =,I5,/1X,
     151HTIME FOR CALCULATION OF STARTING SUBSPACE         =,F9.3,/1X,
     251HTIME FOR LDLT FACTORIZATION OF STIFFNESS MATRIX   =,F9.3,/1X,
     351HTIME FOR CALCULATION OF PROJECTIONS OF A AND B    =,F9.3,/1X,
     451HTIME FOR SOLVING EIGENSYSTEM OF SUBSPACE OPERATORS=,F9.3,/1X
     551HTIME FOR SORTING EIGENVALUES, NORMALISING VECTORS =,F9.3,/1X,
     651HTIME FOR CALCULATING AND APPLYING SHIFTS          =,F9.3,/1X
     751HTIME FOR ERROR NORMS AND STURM SEQUENCE CHECK     =,F9.3,//1X,
     851HTIME FOR EIGENSOLUTION                            =,F9.3,//)
 2250 FORMAT (6E15.5/)
C
      END
C *CDC* *DECK STARTV
C *UNI* )FOR,IS N.STARTV, R.STARTV
      SUBROUTINE STARTV (A,B,XM,TT,W,WW,R,MAXA,NCOLBV,ICOPL,NLOC,D,
     1                   M1,M2,NN,ISTOH,NBLOCK,KKK)
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   PROGRAM TO GENERATE STARTING VECTORS FOR SUBSPACE ITERATION     .
C .   USING TRUNCATED LANCZOS ALGORITHM                               .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MAL
      COMMON /EL/ IXY,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /TAPES/ IIN,IOUT
      COMMON /FAST/ SHIFT1,SHIFT2,IOVER,IRPC,NSTV,IINTER,JROLD,NSCH1,
     1              IACCN,NJUNK,ISVTYP
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /RQSHF/ IRQS
      COMMON /RHSV/ NVEC
C
      DIMENSION A(ISTOH),B(ISTOH),XM(1),TT(1),W(1),WW(1),R(NN,1),D(1)
      INTEGER MAXA(1),NCOLBV(1),ICOPL(1),NLOC(1)
C
      REWIND NSHIFT
      NJ=1
      BETOL=0.0001
      RQTOL=0.0000001D0
      GSTOL=0.001
      IF (IFPR.NE.0) WRITE (IOUT,2000)
C
C     ORTHOGONALISE STARTING VECTOR TO CONVERGED VECTORS ON TAPE NT
C
   10 IF (NCEV.EQ.0) GO TO 60
      REWIND NT
      DO 40 I=1,NCEV
      READ (NT) (TT(K),K=1,NN),(WW(K),K=1,NN)
      AL=0.
      DO 20 K=1,NN
   20 AL=AL + R(K,M1)*WW(K)
      DO 30 K=1,NN
   30 R(K,M1)=R(K,M1) - AL*TT(K)
   40 CONTINUE
C
   60 IF (IMASS.EQ.1) GO TO 65
      CALL MLTPLY (TT,B,R(1,M1),MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 75
   65 DO 70 K=1,NN
   70 TT(K)=XM(K)*R(K,M1)
C
C     ORTHOGONALISE STARTING VECTOR TO THE VECTORS IN-CORE CURRENTLY
C
   75 IF (M1.EQ.1) GO TO 110
      IF (KKK.EQ.1) REWIND NSHIFT
      MM=M1 - 1
      DO 90 I=1,MM
      AL=0.
      DO 80 K=1,NN
   80 AL=AL + R(K,M1)*R(K,I)
      DO 85 K=1,NN
   85 TT(K)=TT(K) - AL*R(K,I)
      IF (KKK.GT.1) GO TO 90
      READ (NSHIFT) (WW(K),K=1,NN)
      DO 88 K=1,NN
   88 R(K,M1)=R(K,M1) - AL*WW(K)
   90 CONTINUE
      IF (KKK.EQ.1) GO TO 110
C
      DO 92 K=1,NN
   92 R(K,M1)=TT(K)
      CALL BANDET (A,B,XM,TT,W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,
     1             SHIFT,NSCH,IMASS,FDETA,IDETA,2)
      ALFA=0.
      DO 100 K=1,NN
  100 ALFA=ALFA + TT(K)*R(K,M1)
C
      IF (IMASS.EQ.1) GO TO 105
      CALL MLTPLY (R(1,M1),B,TT,MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 130
  105 DO 108 K=1,NN
  108 R(K,M1)=XM(K)*TT(K)
      GO TO 130
C
  110 DO 120 K=1,NN
      DUM=TT(K)
      TT(K)=R(K,M1)
  120 R(K,M1)=DUM
      ALFA=0.
C
  130 BETA=0.
      DO 135 K=1,NN
  135 BETA=BETA + TT(K)*R(K,M1)
      D(NJ)=ALFA/BETA
      BETA=DSQRT(BETA)
      GAMA=BETA
      DO 140 K=1,NN
      TT(K)=TT(K)/BETA
  140 R(K,M1)=R(K,M1)/BETA
      IF (IFPR.NE.0) WRITE (IOUT,2020) M1,ALFA,BETA,GAMA,D(NJ)
C
      WRITE (NSHIFT) (TT(K),K=1,NN)
      IF (M1.EQ.M2) GO TO 500
      BETA=0.
      DO 210 K=1,NN
  210 WW(K)=0.
      MM=M1 + 1
C
      DO 400 J=MM,M2
      J1=J - 1
C
C     INVERSE ITERATION
C
      DO 220 K=1,NN
  220 R(K,J)=R(K,J1)
      CALL BANDET (A,B,XM,R(1,J),W,MAXA,NCOLBV,ICOPL,NN,ISTOH,NBLOCK,
     1             SHIFT,NSCH,IMASS,FDETA,IDETA,2)
C
C     COMPUTE AND CHECK THE RAYLEIGH QUOTIENT
C
      ALFA=0.
      DO 230 K=1,NN
  230 ALFA=ALFA + R(K,J)*R(K,J1)
      RQT=ALFA
      DO 240 K=1,NN
  240 R(K,J)=R(K,J) - ALFA*TT(K) - BETA*WW(K)
      DO 250 K=1,NN
  250 WW(K)=TT(K)
C
C     NORMALISE THE NEW VECTOR
C
      RQB=ALFA*ALFA + BETA*BETA
      IF (IMASS.EQ.1) GO TO 265
      CALL MLTPLY (TT,B,R(1,J),MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 275
  265 DO 270 K=1,NN
  270 TT(K)=XM(K)*R(K,J)
  275 BETA=0.
      DO 280 K=1,NN
  280 BETA=BETA + R(K,J)*TT(K)
      RQB=RQB + BETA
      RQ=RQT/RQB
      BETA=DSQRT(BETA)
      GAMA=DSQRT(RQB)
      DO 285 K=1,NN
  285 R(K,J)=R(K,J)/BETA
      IF (IFPR.NE.0) WRITE (IOUT,2020) J,ALFA,BETA,GAMA,RQ
C
C     CHECK FOR THE LINEAR INDEPENDENCE OF THE LANCZOS VECTORS
C
      DO 290 I=1,NJ
      IF (DABS(D(NJ) - RQ).LE.DABS(RQ)*RQTOL) GO TO 295
  290 CONTINUE
      IF (BETA/GAMA.GT.BETOL) GO TO 300
  295 DO 298 K=1,NN
  298 R(K,J)=0.
      IJ=NLOC(NCEV + J)
      R(IJ,J)=1.
      M1=J
      NJ=NJ + 1
      GO TO 10
C
C     MASS ORTHOGONALISE THE NEW VECTOR TO PREVIOUSLY OBTAINED VECTORS
C
  300 REWIND NSHIFT
      IFLAG=0
      DO 330 I=1,NJ
      READ (NSHIFT) (TT(K),K=1,NN)
      IF (IFLAG.GT.0) GO TO 330
      AL=0.
      DO 310 K=1,NN
  310 AL=AL + R(K,J)*R(K,I)
      IF (DABS(AL).GT.GSTOL) IFLAG=1
      DO 320 K=1,NN
  320 R(K,J)=R(K,J) - AL*TT(K)
  330 CONTINUE
      IF (IFLAG.GT.0) GO TO 295
C
      DO 340 K=1,NN
  340 TT(K)=R(K,J)
      IF (IMASS.EQ.1) GO TO 350
      CALL MLTPLY (R(1,J),B,TT,MAXA,NN,NCOLBV,ISTOH,NBLOCK,NMASS)
      GO TO 370
  350 DO 360 K=1,NN
  360 R(K,J)=XM(K)*TT(K)
C
  370 AL=0.
      DO 380 K=1,NN
  380 AL=AL + TT(K)*R(K,J)
      AL=DSQRT(AL)
      DO 390 K=1,NN
      TT(K)=TT(K)/AL
  390 R(K,J)=R(K,J)/AL
C
      NJ=NJ + 1
      D(NJ)=RQ
      WRITE (NSHIFT) (TT(K),K=1,NN)
  400 CONTINUE
C
C     ORTHOGONALISE THE RANDOM STARTING VECTOR TO THE OTHERS
C
  500 IF (KKK.GT.1 .OR. IINTER.EQ.0) GO TO 600
      REWIND NSHIFT
      DO 530 J=1,M2
      AL=0.
      DO 510 K=1,NN
  510 AL=AL + R(K,NQ)*R(K,J)
      READ (NSHIFT) (TT(K),K=1,NN )
      DO 520 K=1,NN
  520 R(K,NQ)=R(K,NQ) - AL*TT(K)
  530 CONTINUE
C
  600 RETURN
C
 2000 FORMAT (///,49H STARTING VECTORS ARE GENERATED BY LANCZOS METHOD /
     1     /,7H VECTOR,59H     ALFA           BETA           GAMA
     1  RAYL. QUO.     /)
 2020 FORMAT (I7,4E15.5)
 2050 FORMAT (21H GRAM-SCHMIDT FACTORS,(/8E15.5))
C
      END
C *CDC* *DECK RAPID
C *UNI* )FOR,IS N.RAPID, R.RAPID
      SUBROUTINE RAPID (EIGV,D,TT,W,EVC1,EVC2,RTOLV,R,RR,FREQ,WW,XM,
     1                  NLOC,NSIT,NN,NQ)
C
C     PROGRAM TO STUDY THE CONVERGENCE OF SUBSPACE ITERATIONS AND
C     INVESTIGATE THE POSSIBILITIES OF ACCELERATING IT
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MAL
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /SCRAP/ SHIFT,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQA,IFSS
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /ITELMT/ NSMAX,NITEM,NITEMM,NOVM
      COMMON /FAST/ SHIFT1,SHIFT2,IOVER,IRPC,NSTV,IINTER,JROLD,NSCH1,
     1              IACCN,NJUNK,ISVTYP
      COMMON /DIMSSP/ M3,M4,M5,M6,M7,M8,M9
      COMMON /TAPES/ IIN,IOUT
      COMMON /TAPEIG/ SCALE,NSTIF,NT,NMASS,NRED,NSHIFT,NOVER
      COMMON /TOLS/ RTOL,ALPHA,CTOL,ANORM,RCTOL
C
      REAL A
      COMMON A(1)
      INTEGER IA(1)
      EQUIVALENCE (A(1),IA(1))
C
      DIMENSION EIGV(1),D(1),TT(1),W(1),EVC1(1),EVC2(1),RTOLV(1),R(NN,1)
     1         ,RR(NN,1),FREQ(1),WW(1),XM(1),NLOC(1),NSIT(1)
      DATA NFAC/0/, NGS/0/
C
      RMUS=SHIFT
      SHIFTO=SHIFT
      RITOL=RTOL
      IF (IINTER.GT.0) RITOL=RCTOL
      NP=NFREQ - NCEV
      IF (NQ.LT.NP) RITOL=RCTOL
      IVSHF=0
C
      NEIG=0
      DO 580 I=1,NQ
      IF (RTOLV(I).GT.RITOL) GO TO 590
      NEIG=I
      IF (NLOC(NCEV + I).GT.0) GO TO 580
      NLOC(I + NCEV)=NITE - NSIT(I)
  580 CONTINUE
C
  590 IF (NEIG.EQ.0) GO TO 600
      IF (EIGV(NEIG).GE.SHIFT2) GO TO 595
      IF (IINTER.GT.0) GO TO 600
      IF (NCEV + NEIG.LT.NFREQ) GO TO 600
  595 NFREQ=NCEV + NEIG
      ICONV=1
      JR=0
      IF (IFPR.NE.0) WRITE (IOUT,2060) RTOL,NITE,NFAC,NGS
      GO TO 910
C
  600 IF (NITE.LT.NITEMM) GO TO 700
      WRITE (IOUT,2070)
      ICONV=2
      IFSS=0
      NFREQ=NCEV + NEIG
      JR=0
      GO TO 910
C
C     CALCULATE RATE OF CONVERGENCE
C
  700 NC=NFREQ - NCEV
      IF (NC.GT.NQ .OR. IINTER.GT.0) NC=NQ
      IF (NC.GT.0) GO TO 705
      WRITE (IOUT,3010)
      STOP
  705 IF (IACCN.EQ.0) GO TO 1200
      IF (RITOL.EQ.RCTOL) GO TO 720
      NEIG=0
      DO 710 I=1,NQ
      IF (RTOLV(I).GT.RCTOL) GO TO 720
      NEIG=I
  710 CONTINUE
  720 IF (NEIG.LT.NQ) GO TO 730
      IVSHF=1
      GO TO 910
C
  730 IF (NITE.LE.NSTEP - 2) GO TO 910
      DO 740 I=1,NC
      TEMP=D(I) - EVC2(I)
      EVC2(I)=0.
      IF (DABS(TEMP).GT.D(I)*1.D-10) EVC2(I)=(EIGV(I) - D(I))/TEMP
  740 CONTINUE
      IF (IFPR.GT.1)
     1 WRITE (IOUT,2300) (EVC2(I),I=1,NC)
      IF (NITE.EQ.NSTEP - 1) GO TO 910
      IF (IFPR.GT.1)
     1 WRITE (IOUT,2350) (EVC1(I),I=1,NC)
C
C     ESTABLISH LAMBDA (Q + 1) FROM FAIRLY CONVERGED ROOTS
C
      DO 750 I=1,NC
      TT(I)=EIGV(NQ)*2.**30
      IF (RTOLV(I).GT.1.D-3 .OR. RTOLV(I).LT.RCTOL) GO TO 750
      IF (EVC2(I).GT.0.99 .OR. EVC2(I).LT.1.D-5) GO TO 750
      TEMP=EVC2(I) - EVC1(I)
      TEMP=DABS(TEMP/EVC2(I))
      IF (TEMP.GT.CTOL) GO TO 750
      TT(I)=(EIGV(I) - RMUS)/DSQRT(EVC2(I)) + RMUS
      IF (TT(I).LT.RMUS) GO TO 750
      IF (RTOLV(I).GT.RCTOL) NLOC(NCEV + I)=-1
  750 CONTINUE
      IF (IFPR.GT.1)
     1 WRITE (IOUT,2400) (TT(I),I=1,NC)
C
      MLQ=0
      TLQ=0.
      DO 760 I=1,NC
      IF (TT(I).GE.EIGV(NQ)*2.**30) GO TO 760
      IF (TT(I).LT.RMUS) GO TO 760
      MLQ=MLQ + 1
      TLQ=TLQ + TT(I)
  760 CONTINUE
C
      IF (MLQ.NE.0)
     1 RLQ1=(NLQ*RLQ1 + TLQ)/(NLQ + MLQ)
      NLQ=MLQ + NLQ
      IF (IFPR.NE.0)
     1 WRITE (IOUT,2500) RLQ1,NLQ
      IF (RLQ1.GT.0.) GO TO 762
      IF (NITE.EQ.NITEMM - 1 .AND. NEIG.GT.0) IVSHF=1
      GO TO 910
C
C     ESTABLISH SHIFT  FROM THE SET OF VECTORS CONVERGED TO RTOL SO FAR
C
  762 J=1
      DO 763 I=1,NC
      IF (EIGV(I).GT.RMUS) GO TO 765
      J=J + 1
  763 CONTINUE
C
  765 IF (J.GT.NC) J=NC
      NR=J
      DO 770 I=J,NC
      IF (RTOLV(I).GT.RCTOL) GO TO 773
      NR=NR + 1
  770 CONTINUE
C
  773 IF (NR.GT.NC) NR=NC
      K=NR
      BAND=EIGV(1) + (RLQ1 - EIGV(1))/3
C
  775 NR=NR - 1
      IF (NR.LE.J) GO TO 778
      SHIFT=0.5*(EIGV(NR) + EIGV(NR - 1))
      IF (SHIFT.LT.1.01*EIGV(NR - 1)) GO TO 775
      IF (SHIFT.GT.0.99*EIGV(NR)) GO TO 775
      IF (SHIFT.GT.BAND) GO TO 775
      J=NR
      GO TO 790
C
C     SPECIAL CASE - (1) SHIFT TO THE LEFT OF THE FIRST EIGENVALUE
C
  778 IF (J.GT.1) GO TO 788
      IF (NCEV.GT.0) GO TO 780
      SHIFT=0.5*EIGV(1)
      IF (SHIFT.LE.RMUS) GO TO 910
      J=1
      GO TO 790
C
C     SPECIAL CASE - (2) SHIFT BETWEEN EIGENVALUES IN BACK-UP STORE
C
  780 NR=NCEV + 2
      FREQ(NCEV + 1)=EIGV(1)
      IF (RTOLV(1).GT.RCTOL) NR=NR - 1
  785 NR=NR - 1
      IF (NR.LT.1) GO TO 910
      SHIFT=0.5*FREQ(NR)
      IF (NR.GT.1) SHIFT=SHIFT + 0.5*FREQ(NR - 1)
      IF (SHIFT.LE.RMUS) GO TO 910
      IF (SHIFT.LT.1.01*FREQ(NR - 1)) GO TO 785
      IF (SHIFT.GT.0.99*FREQ(NR)) GO TO 785
      J=NR - NCEV
      GO TO 790
C
C     IF THE MAXIMUM POSSIBLE SHIFT WITHIN THE CURRENT BASIS HAS BEEN
C     REACHED, CONSIDER EXPANSION OF THE BASIS FOR ACCELERATION
C
  788 TEMP=0.5*(EIGV(K) + EIGV(K - 1))
      IF (TEMP.GT.BAND) IVSHF=1
      GO TO 910
C
C     CHECK HOW MANY MORE ITERATIONS WOULD BE REQUIRED WITH THIS SHIFT
C
  790 SI=0.
      II=NC
      DO 800 I=K,NC
      IF (EIGV(I).GE.RLQ1) GO TO 800
      IF (RTOLV(I).LE.RITOL .OR. RTOLV(I).GT.0.01) GO TO 800
      TOLI=RITOL/RTOLV(I)
      DI=((EIGV(I) - RMUS)/(RLQ1 - RMUS))**2
      ST=DLOG10(TOLI)/DLOG10(DI)
      DP=((EIGV(I) - SHIFT)/(RLQ1 - SHIFT))**2
      STP=DLOG10(TOLI)/DLOG10(DP)
      SII=ST - STP
      IF (SII.LE.SI) GO TO 800
      SI=SII
      II=I
  800 CONTINUE
      I=II
      TOLI=RITOL/RTOLV(I)
      DI=((EIGV(I) - RMUS)/(RLQ1 - RMUS))**2
      ST=DLOG10(TOLI)/DLOG10(DI)
      DP=((EIGV(I) - SHIFT)/(RLQ1 - SHIFT))**2
      STP=DLOG10(TOLI)/DLOG10(DP)
C
C     CHECK TO SEE WHETHER IT IS WORTH SHIFTING
C
      IF (SI.GT.3.) GO TO 820
      NOFAC=0
      NOSI=0
      IF (K.LE.1) GO TO 850
      TEMP=0.5*(EIGV(K) + EIGV(K - 1))
      IF (TEMP.LT.BAND) GO TO 850
      IVSHF=1
      GO TO 910
C
  820 MA=NWK/NN + 1
      NOFAC=(MA*MA + 3*MA)/2
      IF (IMASS.EQ.2) NOFAC=NOFAC + MA
      NP=NQ - JR
      NOSI=(2*MA*NP + 2*NP*NP + 3*NP + 2*NP*JR + 2*NQ*NCEV)*SI
      IF (IMASS.EQ.2) NOSI=NOSI + 2*MA*NP*SI
      NOSI=NOSI + 18*NP*NP*NP*SI/NN
      IF (NOFAC.GE.ALPHA*NOSI) GO TO 850
C
C      SHIFT IS GOOD. PRINT ALL INFORMATION. SHIFT K MATRIX.
C
      IF (IFPR.NE.0) WRITE (IOUT,2600)
      NSTEP=4 + NITE
      RMUS=SHIFT
      NFAC=NFAC + 1
C
      CALL BANDET (A(N2),A(M3),A(M4),TT,W,A(N1),A(N1A),A(N1B),NN,
     1             ISTOH,NBLOCK,SHIFT,NSCH,IMASS,FDETA,IDETA,1)
C
C     PERFORM STURM SEQUENCE CHECK AT THE CURRENT SHIFT.
C
      IF (IFPR.NE.0) WRITE (IOUT,2650) NSCH
      IF (NSCH.EQ.NSCH1 + NCEV + J - 1) GO TO 855
      WRITE (IOUT,2680)
      IFSS=0
      GO TO 595
C
  850 IF (IFPR.NE.0) WRITE (IOUT,2690)
  855 IF (IFPR.EQ.0) GO TO 910
      J=J + NCEV + NSCH1
      I=I + NCEV + NSCH1
      WRITE (IOUT,2700) J,I,SHIFT
      WRITE (IOUT,2800) TOLI,DI,DP,ST,STP,NOFAC,NOSI
C
  910 SHIFT=RMUS
      IF (IACCN.EQ.0) GO TO 1200
C
C     REORTHOGONALISE W.R.T. CONVERGED VECTORS IN THE CRITICAL BAND
C
      IF (NCEV.EQ.0) GO TO 985
      REWIND NT
      BAND=DABS(EIGV(NQ) - SHIFT)
      JJ=JR + 1
      NORTHO=0
      DO 980 J=1,NCEV
      IF (NJUNK.GT.0) GO TO 930
      RT=DABS(FREQ(J) - SHIFT)
      IF (RT.LE.BAND) GO TO 930
      READ (NT)
      GO TO 980
C
  930 READ (NT) (TT(I),I=1,NN),(WW(I),I=1,NN)
      NORTHO=NORTHO + 1
      DO 970 K=JJ,NQA
      AL=0.
      DO 940 I=1,NN
  940 AL=AL + TT(I)*RR(I,K)
      DO 950 I=1,NN
  950 RR(I,K)=RR(I,K) - AL*WW(I)
  970 CONTINUE
  980 CONTINUE
      IF (IFPR.NE.0) WRITE (IOUT,2850) NORTHO
      NGS=NGS + NORTHO
C
C     OVERRELAX ITERATION VECTOR IF LINEAR CONVERGENCE HAS BEEN OBTAINED
C
  985 IF (IOVER.NE.1) GO TO 1000
      IF (NITE.GT.NSTEP-4 .AND. NITE.LE.NSTEP-1) GO TO 1000
      REWIND NOVER
      IF (NJUNK.EQ.0) GO TO 987
      DO 986 J=1,NJUNK
  986 READ (NOVER)
C
  987 JJ=JROLD + 1
      DO 995 J=JJ,NC
      IF (NLOC(NCEV + J).EQ.-1) GO TO 988
      READ (NOVER)
      GO TO 995
C
  988 NLOC(NCEV + J)=0
      READ (NOVER) (TT(K),K=1,NN)
      RC=(EIGV(J) - SHIFTO)/(RLQ1 - SHIFTO)
      RA=1./(1. - RC)
      DO 990 K=1,NN
  990 R(K,J)=TT(K) + (R(K,J) - TT(K))*RA
      K=J + NJUNK
      IF (IFPR.NE.0) WRITE (IOUT,2820) K
  995 CONTINUE
C
C     IF ALLOWED, THROW SOME VECTORS FROM THE CURRENT BASIS OUT
C
 1000 IF (IVSHF.EQ.0) GO TO 1200
      K=NEIG
      IF (JR.GT.0) K=JR
      IF (IINTER.GT.0) GO TO 1015
C
      NP=NFREQ - NCEV
      NC=MIN0(2*NP,NP + 8)
      IF (NQ.LT.NC) GO TO 1010
      GO TO 1200
C
 1010 NC=NQ/2
      IF (NQ.GT.16) NC=NQ - 8
      IF (NP.LT.NC + K) K=NP - NC
      IF (NCEV+K+NQ.GT.NN) K=NN - (NCEV + NQ)
 1015 IF (K.EQ.0) GO TO 1200
      NLQ=0
      RLQ1=0.
      NSTEP=NITE + 4
      NITEMM=NITE + NITEM
      IF (NCEV.EQ.0) REWIND NT
      DO 1050 J=1,K
      FREQ(NCEV + J)=EIGV(J)
      DO 1030 I=1,NN
 1030 TT(I)=(EIGV(J) - SHIFT)*R(I,J)
C
      CALL BANDET (A(N2),A(M3),A(M4),TT,W,A(N1),A(N1A),A(N1B),NN,
     1             ISTOH,NBLOCK,SHIFT,NSCH,IMASS,FDETA,IDETA,2)
C
      IF (IMASS.EQ.1) GO TO 1035
      CALL MLTPLY (R(1,J),A(M3),TT,A(N1),NN,A(N1A),ISTOH,NBLOCK,NMASS)
      GO TO 1040
 1035 DO 1038 I=1,NN
 1038 R(I,J)=XM(I)*TT(I)
 1040 AL=0.
      DO 1042 I=1,NN
 1042 AL=AL + TT(I)*R(I,J)
      AL=DSQRT(AL)
      DO 1045 I=1,NN
      TT(I)=TT(I)/AL
 1045 R(I,J)=R(I,J)/AL
      WRITE (NT) (TT(I),I=1,NN),(R(I,J),I=1,NN)
 1050 CONTINUE
C
C     SHIFT EIGENPAIRS IN THE CURRENT BASIS
C
      IF (IFPR.NE.0) WRITE (IOUT,2900) NCEV,NP,K
      NCEV=NCEV + K
      IF (IINTER.EQ.0) GO TO 1060
      IF (NCEV.LE.50) GO TO 1052
      WRITE (IOUT,3000)
      IVSHF=0
      NCEV=NCEV - K
      GO TO 595
C
C     SPECIAL CASE - INTERMEDIATE EIGENVALUES SOLUTION ONLY
C
 1052 IF (NJUNK.EQ.0) GO TO 1060
      NR=NCEV + 1
 1055 NR=NR - 1
      IF (NR.LT.2) GO TO 1060
      RMUS=0.5*(FREQ(NR) + FREQ(NR - 1))
      IF (RMUS.LE.SHIFT) GO TO 1060
      IF (RMUS.LT.1.01*FREQ(NR - 1)) GO TO 1055
      IF (RMUS.GT.0.99*FREQ(NR)) GO TO 1055
      NFAC=NFAC + 1
      SHIFT=RMUS
      IF (IFPR.NE.0) WRITE (IOUT,2920) SHIFT
C
      CALL BANDET (A(N2),A(M3),A(M4),TT,W,A(N1),A(N1A),A(N1B),NN,
     1             ISTOH,NBLOCK,SHIFT,NSCH,IMASS,FDETA,IDETA,1)
C
      IF (IFPR.NE.0) WRITE (IOUT,2650) NSCH
      IF (NSCH.EQ.NSCH1 + NR - 1) GO TO 1060
      WRITE (IOUT,2680)
      IVSHF=0
      NCEV=NCEV - K
      IFSS=0
      GO TO 595
C
 1060 NP=NQ - K
      IF (NP.EQ.0) GO TO 1090
      JR=JR - K
      IF (JR.LT.0) JR=0
      DO 1080 N=1,NP
      J=N + K
      EIGV(N)=EIGV(J)
      NSIT(N)=NSIT(J)
      DO 1070 I=1,NN
 1070 R(I,N)=R(I,J)
 1080 CONTINUE
C
C     ESTABLISH NEW STARTING VECTORS AND ORTHOGONALISE THEM
C
 1090 NP=NP + 1
      DO 1092 J=NP,NQ
      EIGV(J)=0.
      NSIT(J)=NITE
 1092 CONTINUE
C
      DO 1097 J=NP,NQ
      IF (NCEV + J.GT.NSTV) GO TO 1098
      READ (NSHIFT) (TT(I),I=1,NN)
      NLOC(NCEV + J)=0
      IF (IMASS.EQ.1) GO TO 1093
      CALL MLTPLY (R(1,J),A(M3),TT,A(N1),NN,A(N1A),ISTOH,NBLOCK,NMASS)
      GO TO 1097
 1093 DO 1095 I=1,NN
 1095 R(I,J)=XM(I)*TT(I)
 1097 CONTINUE
      GO TO 1115
C
 1098 K=J
      DO 1105 J=K,NQ
      DO 1100 I=1,NN
 1100 R(I,J)=0.
      IJ=NLOC(NCEV + NJUNK + J)
      R(IJ,J)=1.
      IF (ISVTYP.GT.0) GO TO 1107
 1105 CONTINUE
      GO TO 1109
C
 1107 M1=NJUNK + J
      CALL STARTV (A(N2),A(M3),A(M4),TT,W,WW,RR,A(N1),A(N1A),A(N1B),
     1             NLOC,D,M1,NQA,NN,ISTOH,NBLOCK,2)
C
 1109 DO 1110 J=K,NQ
 1110 NLOC(NCEV + J)=0
C
 1115 REWIND NT
      DO 1150 J=1,NCEV
      READ (NT) (TT(I),I=1,NN),(WW(I),I=1,NN)
      DO 1140 K=NP,NQ
      AL=0.
      DO 1120 I=1,NN
 1120 AL=AL + TT(I)*R(I,K)
      DO 1130 I=1,NN
 1130 R(I,K)=R(I,K) - AL*WW(I)
 1140 CONTINUE
 1150 CONTINUE
C
C     WRITE TRIAL VECTORS ONTO TAPE NT FOR FUTURE OVERRELAXATION
C
 1200 IF (NBLOCK.EQ.1 .AND. (IACCN.EQ.0.OR.NITE.LT.NSTEP-1)) GO TO 1300
      JROLD=JR
      REWIND NOVER
      IF (NJUNK.EQ.0) GO TO 1204
      DO 1202 J=1,NJUNK
 1202 WRITE (NOVER) (RR(K,J),K=1,NN)
 1204 JJ=JR + 1
      DO 1205 J=JJ,NQ
 1205 WRITE (NOVER) (R(K,J),K=1,NN)
      IF (NBLOCK.EQ.1) GO TO 1300
C
C     FOR OUT-OF-CORE SOLUTION POSITION TAPE NT
C
      REWIND NOVER
C
 1300 RETURN
C
C
 2060 FORMAT (///,30H CONVERGENCE REACHED FOR RTOL  E10.4,2X,
     1        14H  AT ITERATION,I4 /,
     2        37H NUMBER OF FACTORIZATIONS PERFORMED =,I5/,
     3        44H NUMBER OF GRAM-SCHMIDT ORTHOGONALIZATIONS =,I6//)
 2070 FORMAT (1H1,51H*** NO CONVERGENCE IN MAXIMUM NUMBER OF ITERATIONS
     1             9HPERMITTED/35H WE ACCEPT CURRENT ITERATION VALUES/
     2            42H THE STURM SEQUENCE CHECK IS NOT PERFORMED  )
 2300 FORMAT (///44H RATE OF CONVERGENCE ESTIMATES,RI(I + 1) ARE,/(6E15.
     1             5/))
 2350 FORMAT (///44H RATE OF CONVERGENCE ESTIMATES,RI(I    ) ARE,/(6E15.
     1             5/))
 2400 FORMAT (///31H ESTIMATES OF LAMBDA(Q + 1) ARE,/,(6E15.5/))
 2500 FORMAT (///36H AVERAGE ESTIMATE OF LAMDA(Q+1) IS =,E20.10,    /
     1            9H BASED ON,I5,10H ESTIMATES   )
 2600 FORMAT (//51H NOFAC IS LESS THAN ALPHA*NOSI AND SHIFT IS APPLIED/)
 2650 FORMAT (//46H STURM SEQUENCE CHECK PERFORMED AT THIS SHIFT. /
     1          60H ESTIMATED NUMBER OF EIGENVALUES TO THE LEFT OF THIS
     2SHIFT =,I5/)
 2680 FORMAT (14H CHECK FAILED. /
     1        81H ESTIMATED NUMBER OF EIGENVALUES IS MORE THAN THE NUMBE
     2R OF COMPUTED EIGENVALUES. /55H REPEAT SOLUTION WITH A LARGER NUMB
     3ER OF TRIAL VECTORS.   /35H ALSO USE A SMALLER VALUE FOR RTOL //)
 2690 FORMAT (//52H SHIFT CALCULATED DOES NOT SATISFY SHIFTING CRITERIA)
 2700 FORMAT (//,31H SHIFT ESTIMATED TO THE LEFT OF,I3,15HTH EIGENVALUE
     1,10H BASED ON ,I3,18HTH EIGENVALUE IS =,E15.5/)
 2800 FORMAT (///11X,4HTOLI,14X,1HD,13X,2HDP,14X,1HT,13X,2HTP,4X,5HNOFAC
     1       ,5X,4HNOSI//,5E15.5,2I9)
 2820 FORMAT (42H OVER-RELAXATION IS PERFORMED FOR VECTOR =,I4)
 2850 FORMAT (//53H GRAM-SCHMIDT ORTHOGONALISATION OF CURRENT TRIAL VECT
     1 36HORS IS PERFORMED W.R.T. THE PREVIOUS,I4,13H EIGENVECTORS  )
 2900 FORMAT (//35H EIGENVECTORS ARE TAKEN OUT        , /
     1          45H NUMBER OF EIGENVECTORS ALREADY REMOVED     =,I5,/,
     2          44H NUMBER OF EIGENPAIRS YET TO BE CALCULATED =,I5/,
     3          49H NUMBER OF EIGENVECTORS CURRENTLY BEING REMOVED =,I5)
 2920 FORMAT (//,81H IN ORDER TO MOVE THE POLE OF ATTRACTION TO THE RIGH
     1T, A SHIFT  IS ALSO PERFORMED /,16H SHIFT APPLIED =,E15.5)
C
 3000 FORMAT (1H1,///,14H *** ERROR ***,/,
     1        55H STORAGE OVERFLOW OCCURED.  IN A GIVEN INTERVAL ONLY A
     2        47H MAXIMUM OF FIFTY EIGENVALUES CAN BE CALCULATED  )
 3010 FORMAT (1H1,//45H *** STOP ***, ERROR OCCURED IN EIGENSOLUTION,/,
     159H INCREASE NUMBER OF VECTORS USED (NQ) IN SUBSPACE ITERATION  )
C
      END
C *CDC* *DECK SCHECK
C *UNI* )FOR,IS N.SCHECK, R.SCHECK
      SUBROUTINE SCHECK (EIGV,RTOLV,BUP,BLO,BUPC,NEIV,NC,NEI,RTOL,SHIFT)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .   P R O G R A M                                                   .
C .        TO EVALUATE SHIFT FOR STURM SEQUENCE CHECK                 .
C .                                                                   .
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TAPES/ IIN,IOUT
      COMMON /SCRAP/ RMUSS,RLQ1,NLQ,NITE,NSTEP,JR,ICONV,NCEV,NP,NQ,IFSS
C
      DIMENSION EIGV(1),RTOLV(1),BUP(1),BLO(1),BUPC(1),NEIV(1)
C
      FTOL=0.001
C
      DO 100 I=1,NC
      BUP(I)=EIGV(I)*(1. + FTOL)
  100 BLO(I)=EIGV(I)*(1. - FTOL)
C
      NROOT=NCEV
      II=NC - NCEV - 1
      DO 120 I=1,II
      IF (RTOLV(I).GT.RTOL) GO TO 130
      IF (BUP(I).LE.BLO(I + 1)) NROOT=NCEV + I
  120 CONTINUE
      IF (RTOLV(NC - NCEV).LE.RTOL) NROOT=NC
  130 IF (NROOT.GE.1) GO TO 200
      WRITE (IOUT,1010)
      STOP
C
C      FIND UPPER BOUNDS ON EIGENVALUE CLUSTERS
C
 200  DO 240 I=1,NROOT
 240  NEIV(I)=1
      IF (NROOT.NE.1) GO TO 260
      BUPC(1)=BUP(1)
      LM=1
      L=1
      I=2
      IF (NC.EQ.1) GO TO 300
      GO TO 295
 260  L=1
      I=2
 270  IF (BUP(I-1).LE.BLO(I)) GO TO 280
      NEIV(L)=NEIV(L)+1
      I=I+1
      IF (I.LE.NROOT) GO TO 270
 280  BUPC(L)=BUP(I-1)
      IF (I.GT.NROOT) GO TO 290
      L=L+1
      I=I + 1
      IF (I.LE.NROOT) GO TO 270
      BUPC(L)=BUP(I-1)
 290  LM=L
      IF (NROOT.EQ.NC) GO TO 300
 295  IF (BUP(I-1).LE.BLO(I)) GO TO 300
      IF (I.GT.NCEV .AND. RTOLV(I - NCEV).GT.RTOL) GO TO 300
      BUPC(L)=BUP(I)
      NEIV(L)=NEIV(L)+1
      NROOT=NROOT+1
      IF (NROOT.EQ.NC) GO TO 300
      I=I+1
      GO TO 295
C
C      FIND SHIFT
C
  300 WRITE (IOUT,1020)
      WRITE (IOUT,1005) (BUPC(I),I=1,LM)
      WRITE (IOUT,1030)
      WRITE (IOUT,1006) (NEIV(I),I=1,LM)
      LL=LM-1
      IF (LM.EQ.1) GO TO 310
 330  DO 320 I=1,LL
 320  NEIV(L)=NEIV(L)+NEIV(I)
      L=L-1
      LL=LL-1
      IF (L.NE.1) GO TO 330
 310  WRITE (IOUT,1040)
      WRITE (IOUT,1006) (NEIV(I),I=1,LM)
      L=0
      DO 340 I=1,LM
      L=L+1
      IF (NEIV(I).GE.NROOT) GO TO 350
 340  CONTINUE
 350  SHIFT=BUPC(L)
      NEI=NEIV(L)
C
      RETURN
C
 1005 FORMAT (1H0,6E22.14)
 1006 FORMAT (1H0,6I22)
 1010 FORMAT (37H0***ERROR   SOLUTION STOP IN *SCHECK*, / 12X,
     1        21HNO EIGENVALUES FOUND., / 1X)
 1020 FORMAT (///,37H UPPER BOUNDS ON EIGENVALUE CLUSTERS  )
 1030 FORMAT (34H0NO OF EIGENVALUES IN EACH CLUSTER  )
 1040 FORMAT (42H0NO OF EIGENVALUES LESS THAN UPPER BOUNDS  )
      END
C *CDC* *DECK JACOBI
C *UNI* )FOR,IS N.JACOBI, R.JACOBI
      SUBROUTINE JACOBI (A,B,X,EIGV,D,N,NWA,RTOL,SHIFT,NSMAX,IFPR)
C .....................................................................
C .                                                                   .
C .   P R O G R A M                                                   .
C .        TO SOLVE THE GENERALIZED EIGENPROBLEM USING THE            .
C .        GENERALIZED JACOBI ITERATION                               .
C .                                                                   .
C . - - INPUT VARIABLES - -                                           .
C .        A(NWA)    = STIFFNESS MATRIX (ASSUMED POSITIVE DEFINITE)   .
C .              (UPPER TRIANGULAR PART STORED ROWWISE FROM DIAGONAL) .
C .        B(NWA)    = MASS MATRIX (ASSUMED POSITIVE DEFINITE)        .
C .              (UPPER TRIANGULAR PART STORED ROWWISE FROM DIAGONAL) .
C .        X(N,N)    = MATRIX STORING EIGENVECTORS ON SOLUTION EXIT   .
C .        EIGV(N)   = VECTOR STORING EIGENVALUES ON SOLUTION EXIT    .
C .        D(N)      = WORKING VECTOR                                 .
C .        N         = ORDER OF MATRICES A AND B                      .
C .        RTOL      = CONVERGENCE TOLERANCE (USUALLY SET TO 10.**-12).
C .        NSMAX     = MAXIMUM NUMBER OF SWEEPS ALLOWED               .
C .                                  (USUALLY SET TO 15)              .
C .        IFPR      = FLAG FOR PRINTING DURING ITERATION             .
C .            EQ.0    NO PRINTING                                    .
C .            EQ.1    INTERMEDIATE RESULTS ARE PRINTED               .
C .        IOUT      = OUTPUT DEVICE NUMBER                           .
C .                                                                   .
C . - - OUTPUT - -                                                    .
C .        A(NWA)    = DIAGONALIZED STIFFNESS MATRIX                  .
C .        B(NWA)    = DIGONALIZED MASS MATRIX                        .
C .        X(N,N)    = EIGENVECTORS STORED COLUMNWISE                 .
C .        EIGV(N)   = EIGENVALUES                                    .
C .                                                                   .
C .....................................................................
C .   ABS(X)=DABS(X)                                                  .
C .   SQRT(X)=DSQRT(X)                                                .
C .        THIS PROGRAM IS USED IN SINGLE PRECISION ARITHMETIC ON     .
C .        CDC EQUIPMENT AND DOUBLE PRECISION ARITHMETIC ON IBM       .
C .        OR UNIVAC MACHINES .ACTIVATE,DEACTIVATE OR ADJUST ABOVE    .
C .        CARDS FOR SINGLE OR DOUBLE PRECISION ARITHMETIC            .
C .....................................................................
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /TAPES/ IIN,IOUT
      DIMENSION A(NWA),B(NWA),X(N,N),EIGV(N),D(N)
C
C     INITIALIZE EIGENVALUE AND EIGENVECTOR MATRICES
C
      N1=N + 1
      II=1
      DO 10 I=1,N
      IF (B(II).LT.0.) GO TO 3
      IF (A(II).GT.0.) GO TO 4
      IF (SHIFT.GT.0.) GO TO 4
    3 WRITE(IOUT,2020) II,A(II),B(II)
      STOP
    4 D(I)=A(II)/B(II)
      EIGV(I)=D(I)
   10 II=II + N1 - I
      DO 30 I=1,N
      DO 20 J=1,N
   20 X(I,J)=0.
   30 X(I,I)=1.
      IF (N.EQ.1) GO TO 255
C
C     INITIALIZE SWEEP COUNTER AND BEGIN ITERATION
C
      NSWEEP=0
      NR=N-1
   40 NSWEEP=NSWEEP+1
      IF(IFPR.EQ.2) WRITE(IOUT,2000)NSWEEP
C
C     CHECK IF PRESENT OFF-DIAGONAL ELEMENT IS LARGE ENOUGH TO REQUIRE Z
C
      EPS=(.01**NSWEEP)**2
      DO 210 J=1,NR
      JP1=J+1
      JM1=J-1
      LJK=JM1*N - JM1*J/2
      JJ=LJK + J
      DO 210 K=JP1,N
      KP1=K+1
      KM1=K-1
      JK=LJK + K
      KK=KM1*N - KM1*K/2 + K
      EPTOLA=(A(JK)*A(JK))
      EPTLA1=DABS(A(JJ)*A(KK)*EPS)
      EPTOLB=(B(JK)*B(JK))
      EPTLB1=(B(JJ)*B(KK)*EPS)
      IF((EPTOLA.LT.EPTLA1) .AND. (EPTOLB.LT.EPTLB1)) GO TO 210
C
C     IF ZEROING IS REQUIRED, CALCULATE THE ROTATION MATRIX ELEMENTS CA
C
      AKK=A(KK)*B(JK)-B(KK)*A(JK)
      AJJ=A(JJ)*B(JK)-B(JJ)*A(JK)
      AB=A(JJ)*B(KK)-A(KK)*B(JJ)
      CHECK=(AB*AB+4.*AKK*AJJ)/4.
      IF(CHECK)50,60,60
   50 WRITE (IOUT,2020) JJ,A(JJ),B(JJ),KK,A(KK),B(KK),JK,A(JK),B(JK)
      STOP
   60 SQCH=DSQRT(CHECK)
      D1=AB/2.+SQCH
      D2=AB/2.-SQCH
      DEN=D1
      IF(DABS(D2).GT.DABS(D1))DEN=D2
      IF(DEN)80,70,80
   70 CA=0.
      CG=-A(JK)/A(KK)
      GO TO 90
   80 CA=AKK/DEN
      CG=-AJJ/DEN
C
C     PERFORM THE GENERALIZED ROTATION TO ZERO THE PRESENT OFF-DIAGONAL
C
   90 IF(N-2)100,190,100
  100 IF(JM1-1)130,110,110
  110 DO 120 I=1,JM1
      IM1=I - 1
      IJ=IM1*N - IM1*I/2 + J
      IK=IM1*N - IM1*I/2 + K
      AJ=A(IJ)
      BJ=B(IJ)
      AK=A(IK)
      BK=B(IK)
      A(IJ)=AJ+CG*AK
      B(IJ)=BJ+CG*BK
      A(IK)=AK+CA*AJ
  120 B(IK)=BK+CA*BJ
  130 IF(KP1-N)140,140,160
  140 LJI=JM1*N - JM1*J/2
      LKI=KM1*N - KM1*K/2
      DO 150 I=KP1,N
      JI=LJI + I
      KI=LKI + I
      AJ=A(JI)
      BJ=B(JI)
      AK=A(KI)
      BK=B(KI)
      A(JI)=AJ+CG*AK
      B(JI)=BJ+CG*BK
      A(KI)=AK+CA*AJ
  150 B(KI)=BK+CA*BJ
  160 IF(JP1-KM1)170,170,190
  170 LJI=JM1*N - JM1*J/2
      DO 180 I=JP1,KM1
      JI=LJI + I
      IM1=I - 1
      IK=IM1*N - IM1*I/2 + K
      AJ=A(JI)
      BJ=B(JI)
      AK=A(IK)
      BK=B(IK)
      A(JI)=AJ+CG*AK
      B(JI)=BJ+CG*BK
      A(IK)=AK+CA*AJ
  180 B(IK)=BK+CA*BJ
  190 AK=A(KK)
      BK=B(KK)
      A(KK)=AK+2.*CA*A(JK)+CA*CA*A(JJ)
      B(KK)=BK+2.*CA*B(JK)+CA*CA*B(JJ)
      A(JJ)=A(JJ)+2.*CG*A(JK)+CG*CG*AK
      B(JJ)=B(JJ)+2.*CG*B(JK)+CG*CG*BK
      A(JK)=0.
      B(JK)=0.
C
C     UPDATE THE EIGENVECTOR MATRIX AFTER EACH ROTATION
C
      DO 200 I=1,N
      XJ=X(I,J)
      XK=X(I,K)
      X(I,J)=XJ+CG*XK
  200 X(I,K)=XK+CA*XJ
  210 CONTINUE
C
C     UPDATE THE EIGENVALUES AFTER EACH SWEEP
C
      II=1
      DO 220 I=1,N
      IF (B(II).LT.0.) GO TO 212
      IF (A(II).GT.0.) GO TO 215
      IF (SHIFT.GT.0.) GO TO 215
  212 WRITE(IOUT,2020) II,A(II),B(II)
      STOP
  215 EIGV(I)=A(II)/B(II)
  220 II=II + N1 - I
      IF(IFPR.LT.2)GO TO 230
      WRITE(IOUT,2030)
      WRITE(IOUT,2010) (EIGV(I),I=1,N)
C
C     CHECK FOR CONVERGENCE
C
  230 DO 240 I=1,N
      TOL=RTOL*DABS(D(I))
      DIF=DABS(EIGV(I)-D(I))
      IF(DIF.GT.TOL)GO TO 280
  240 CONTINUE
C
C     CHECK ALL OFF-DIAGONAL ELEMENTS TO SEE IF ANOTHER SWEEP IS REQUIRE
C
      EPS=RTOL**2
      DO 250 J=1,NR
      JM1=J-1
      JP1=J+1
      LJK=JM1*N - JM1*J/2
      JJ=LJK + J
      DO 250 K=JP1,N
      KM1=K-1
      JK=LJK + K
      KK=KM1*N - KM1*K/2 + K
      EPSA=(A(JK)*A(JK))
      EPSB=(B(JK)*B(JK))
      EPSA1=DABS(A(JJ)*A(KK)*EPS)
      EPSB1=(B(JJ)*B(KK)*EPS)
      IF((EPSA.LT.EPSA1) .AND. (EPSB.LT.EPSB1)) GO TO 250
      GO TO 280
  250 CONTINUE
C
C     FILL OUT BOTTOM TRIANGLE OF RESULTANT MATRICES AND SCALE EIGENVECT
C
  255 II=1
      DO 275 I=1,N
      BB=DSQRT(B(II))
      DO 270 K=1,N
  270 X(K,I)=X(K,I)/BB
  275 II=II + N1 - I
      IF (IFPR.GT.0) WRITE (IOUT,2040) NSWEEP
      RETURN
C
C     UPDATE  D  MATRIX AND START NEW SWEEP, IF ALLOWED
C
  280 DO 290 I=1,N
  290 D(I)=EIGV(I)
      IF(NSWEEP.LT.NSMAX)GO TO 40
      WRITE (IOUT,2050)
      STOP
C
 2010 FORMAT(1H0,6E20.12)
 2000 FORMAT(27H0SWEEP NUMBER IN *JACOBI* = ,I4)
 2020 FORMAT (38H0*** ERROR  SOLUTION STOP IN JACOBI    /
     1        31H MATRICES NOT POSITIVE DEFINITE /
     2 (4H II=,I4,6HA(II)=,E20.12,6HB(II)=,E20.12))
 2030 FORMAT(36H0CURRENT EIGENVALUES IN *JACOBI* ARE,/)
 2040 FORMAT (//,33H NUMBER OF SWEEPS IN JACOBI ARE =,I4//)
 2050 FORMAT (1H1,12H ** STOP ** /,
     1            39H NO CONVERGENCE IN *JACOBI ITERATIONS*  /,
     2            26H EIGEN SOLUTION ABANDONED )
      END
C *CDC* *DECK OVL210
C *CDC*       OVERLAY (ADINA,21,0)
C *CDC* *DECK MODSUP
C *UNI* )FOR,IS N.MODSUP, R.MODSUP
C *CDC*       PROGRAM MODSUP
      SUBROUTINE MODSUP
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C .                                                                   .
C .      PROGRAM                                                      .
C .      . TO PERFORM MODE SUPERPOSITION ANALYSIS                     .
C .                                                                   .
C .      IND=3 - CALCULATE PHIT*K*PHI FOR LINEAR PORTION OF STIFFNESS .
C .              CALCULATE INITIAL CONDITIONS ON MODAL COORDINATES    .
C .              CALCULATE PARAMETERS FOR TIME INTEGRATION            .
C .                                                                   .
C .      IND=4 - PROJECT NODAL LOADS,  SOLVE MODAL EQUATIONS,         .
C .              COMPUTE NODAL INCREMENTAL DISPLACEMENTS              .
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 /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 /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /CONST/ DT,DTA,CONS(21),DTOD,IOPE
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /MSUPCF/ B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10
      COMMON /DISCON/ NDISCE,NIDM
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
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
C
      COMMON A(1)
      REAL A
C
C
      MM=0
      IF (KLIN.GT.0 .AND. (NSUBST.GT.0 .OR. NEGL.GT.0))
     1             MM=NMODES*(NMODES + 1)*ITWO/2
      IF (IND.GE.4) GO TO 100
      IF (KLIN.EQ.0) GO TO 100
      IF (NSUBST.EQ.0 .AND. NEGL.EQ.0) GO TO 100
C
C     CALCULATE PROJECTION OF LINEAR PORTION OF STIFFNESS MATRIX
C     FOR LATER CALCULATION OF RHS LOADS IN NONLINEAR ANALYSIS
C
      M3=N2 + NEQ*ITWO
      M4=M3 + NEQ*ITWO
      M5=N5
      M6=M5 + MM - 1
      CALL SIZE (M6)
C
      CALL MODLOD (A(N1),A(N1A),A(N2),A(M3),A(M4),A(M5),ISTOH,NEQ)
C
C
C
C     AFTER MODLOD THE STIFFNESS PROJECTION BEGINS AT LOCATION M5,
C     (ALSO EQUAL TO N5).
C     IN MODRES THIS STIFFNESS PROJECTION IS SHIFTED TO LOCATION N1
C     AND REMAINS THERE DURING THE REST OF THE SOLUTION.
C
C
C     SETUP STORAGE FOR MODAL VARIABLES
C
  100 M1=N1 + MM
      M2=M1 + NMODES*ITWO
      M3=M2 + NMODES*ITWO
      M4=M3 + NMODES*ITWO
      M5=M4 + NMODES*ITWO
      M6=M5 + NMODES*ITWO
      M7=M6 + NMODES*ITWO
      M8=M7 + NMODES*ITWO
      M9=M8 + NMODES*ITWO
      IF (IND.GE.4) GO TO 200
C
C     CALCULATE INITIAL CONDITIONS AND TIME INTEGRATION PARAMETERS
C
      CALL MODRES (A(M1),A(M2),A(M3),A(M4),A(M5),A(M6),A(M7),
     1             A(N2),A(N7),A(N8),A(N6A),A(N3),A(N4),DT,NEQ)
C
      GO TO 599
C
C     COMPUTE INCREMENTAL DISPLACEMENTS DURING TIME INTEGRATION
C
  200 MADR=N3
      IF (ICOUNT.EQ.3) MADR=N5
C
      CALL DISRES (A(N1),A(M1),A(M2),A(M3),A(M4),A(M5),A(M6),A(M7),A(M8)
     1             ,A(MADR),A(N4),A(N4B),NEQ)
C
  599 CONTINUE
C
      RETURN
C
      END
C *CDC* *DECK MODLOD
C *UNI* )FOR,IS N.MODLOD, R.MODLOD
      SUBROUTINE MODLOD (MAXA,NCOLBV,FI,FK,AA,FTKF,ISTOH,NEQ)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
C
      DIMENSION FI(NEQ),FK(NEQ),AA(ISTOH),FTKF(1)
      INTEGER MAXA(1),NCOLBV(1)
C
      NT=9
      MDIM=NMODES*(NMODES + 1)/2
      DO 10 K=1,MDIM
   10 FTKF(K)=0.
C
      IJ=0
      REWIND NT
      READ (NT) FI
C
C     COMPUTE PROJECTION OF LINEAR PORTION OF STIFFNESS MATRIX
C
      DO 500 I=1,NMODES
C
C     COMPUTE MATRIX VECTOR PRODUCT FK=FK - K*FI
C
      DO 100 K=1,NEQ
  100 FK(K)=0.
      REWIND 4
      CALL MULT (FK,AA,FI,MAXA,NCOLBV,NEQ,ISTOH,NBLOCK,4)
C
C     MULTIPLY FJ VECTOR BY FK VECTOR TO GET THE MATRIX FTKF
C
      DO 400 J=I,NMODES
      TEMP=0.
      DO 200 K=1,NEQ
  200 TEMP=TEMP + FI(K)*FK(K)
      IJ=IJ + 1
      FTKF(IJ)=-TEMP
      IF (J.EQ.NMODES) GO TO 400
      READ (NT) FI
  400 CONTINUE
C
C     POSITION TAPE NT AND READ FI VECTOR
C
      IF (I.GE.NMODES - 1) GO TO 500
      IF (I.GT.NMODES/2) GO TO 450
      REWIND NT
      DO 420 J=1,I
  420 READ (NT)
      GO TO 480
  450 II=NMODES - I
      DO 460 J=1,II
  460 BACKSPACE NT
  480 READ (NT) FI
C
  500 CONTINUE
C
      RETURN
      END
C *CDC* *DECK MODRES
C *UNI* )FOR,IS N.MODRES, R.MODRES
      SUBROUTINE MODRES (P,X,XD,XDD,EIGV,XSI,BETA,DISP,VEL,ACC,TEMPV1,
     1                   TT,PHI,DT,NEQ)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON /SOL/ NUMNP,NNN,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 /DPR/ ITWO
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /MSUPCF/ B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /EIGIF/ COFQ,RBMSH,IESTYP,NFREQ,NMODE,IFPR,IRBM
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /DISCON/ NDISCE,NIDM
C
      COMMON A(1)
      REAL A
C
      DIMENSION P(1),X(1),XD(1),XDD(1),EIGV(1),XSI(1),BETA(1),
     1          DISP(NEQ),VEL(NEQ),ACC(NEQ),TEMPV1(1),PHI(NEQ,1),TT(NEQ)
C
C     TEMPORARILY READ INITIAL CONDITIONS INTO DUMMY LOCATIONS
C     INITIAL DISP INTO VEL, VEL INTO ACC AND ACC INTO TT VECTORS
C
      REWIND 8
      READ (8)
      READ (8) VEL
      READ (8) ACC
      READ (8) TT
C
C     MULTIPLY INITIAL CONDITIONS BY MASS MATRIX
C     AFTER THE MULTIPLICATION - MASS*INITIAL DISP IS STORED IN DISP,
C     MASS*VELOCITY IN VEL,  MASS*ACCELERATION IN ACC VECTORS
C
      IF (IMASS - 1) 20,20,10
C
C     CONSISTENT MASS CASE
C
   10 DO 11 K=1,NEQ
   11 DISP(K)=0.
      REWIND 11
      CALL MULT (DISP,PHI,VEL,A(N1),A(N1A),NEQ,ISTOH,NBLOCK,11)
      DO 12 K=1,NEQ
   12 VEL(K)=0.
      REWIND 11
      CALL MULT (VEL,PHI,ACC,A(N1),A(N1A),NEQ,ISTOH,NBLOCK,11)
      DO 13 K=1,NEQ
   13 ACC(K)=0.
      REWIND 11
      CALL MULT (ACC,PHI,TT,A(N1),A(N1A),NEQ,ISTOH,NBLOCK,11)
      GO TO 40
C
C     LUMPED MASS CASE
C
   20 REWIND 11
      READ (11) (PHI(K,1),K=1,NEQ)
      DO 30 K=1,NEQ
      DISP(K)=-PHI(K,1)*VEL(K)
      VEL(K)=-PHI(K,1)*ACC(K)
      ACC(K)=-PHI(K,1)*TT(K)
   30 CONTINUE
C
C     SHIFT STIFFNESS PROJECTION TO N1
C
   40 IF (KLIN.EQ.0) GO TO 45
      IF (NSUBST.EQ.0 .AND. NEGL.EQ.0) GO TO 45
      MM=NMODES*(NMODES + 1)*ITWO/2
      DO 15 I=1,MM
   15 A(N1+I-1)=A(N5+I-1)
C
C     CALCULATE INITIAL CONDITIONS IN MODAL COORDINATES
C
   45 NT=9
      REWIND NT
      REWIND 7
      READ (7) (XSI(I),I=1,NMODES)
      REWIND 7
      NN=ISTOH
      IF (NBLOCK.GT.1) NN=NN + ISTOH
      NVEC=NN/NEQ
      NX=NMODES/NVEC
      IF (NX*NVEC .LT. NMODES) NX=NX + 1
      NN=1
      DO 100 I=1,NX
      MM=NN + NVEC - 1
      IF (MM.GT.NMODES) MM=NMODES
      JJ=MM - NN + 1
C
      DO 50 J=1,JJ
   50 READ (NT) (PHI(K,J),K=1,NEQ)
      WRITE (7) ((PHI(K,J),K=1,NEQ),J=1,JJ)
C
      DO 70 J=1,JJ
      KK=NN + J - 1
      D1=0.
      D2=0.
      D3=0.
      DO 60 K=1,NEQ
      D1=D1 + PHI(K,J)*DISP(K)
      D2=D2 + PHI(K,J)*VEL(K)
      D3=D3 + PHI(K,J)*ACC(K)
   60 CONTINUE
      X(KK)=-D1
      XD(KK)=-D2
      XDD(KK)=-D3
   70 CONTINUE
C
      NN=NN + NVEC
  100 CONTINUE
      IF (NMODES.EQ.NFREQ) GO TO 101
      II=NFREQ - NMODES
      DO 102 I=1,II
  102 READ (NT)
C
C     READ INITIAL CONDITIONS BACK INTO CORE
C
  101 REWIND 8
      READ (8)
      READ (8) DISP
      READ (8) VEL
      READ (8) ACC
      IF (NDISCE.GT.0)
     1   CALL CONDIS (A(N01),A(N02),A(N03),DISP,VEL,ACC,NIDM,1)
      IF (ITEMPR.LE.1) GO TO 105
      BACKSPACE 56
      NUMP1=NUMNP + 1
      READ (56) (TEMPV1(I),I=1,NUMP1)
  105 CONTINUE
C
C     CALCULATE TIME INTEGRATION PARAMETERS - USING NEWMARK SCHEME
C
  140 READ (NT) (EIGV(I),I=1,NMODES)
      DO 150 I=1,NMODES
  150 XSI(I)=2*XSI(I)*DSQRT(EIGV(I))
C
C
  170 DELT=OPVAR(1)
      ALFA=OPVAR(2)
      DEAL=DELT/ALFA
      B0=1./(ALFA*DT*DT)
      B1=DEAL/DT
      B2=1./(ALFA*DT)
      B3=0.5/ALFA - 1.
      B4=DEAL - 1.
      B5=DT*(0.5*DEAL - 1.)
      B6=DT*(1. - DELT)
      B7=DELT*DT
C
      DO 190 I=1,NMODES
      BETA(I)=B0 + B1*XSI(I) + EIGV(I)
  190 BETA(I)=1./BETA(I)
C
      RETURN
C
      END
C *CDC* *DECK DISRES
C *UNI* )FOR,IS N.DISRES, R.DISRES
      SUBROUTINE DISRES (AA,P,X,XD,XDD,EIGV,XSI,BETA,XI,R,PHI,RE,NEQ)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
      COMMON /MSUPER/ IMODES,NMODES,IMDAMP
      COMMON /MSUPCF/ B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      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,
     1                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON /ADINAI/ OPVAR(7),TSTART,IRINT,ISTOTE
      COMMON /ENERGY/ PE,PEOLD,PEINIT
C
      DIMENSION AA(1),P(1),X(1),XD(1),XDD(1),EIGV(1),XSI(1),BETA(1),
     1          XI(1),R(1),RE(1),PHI(NEQ,1)
C
      NT=7
      DO 10 K=1,NEQ
      RE(K)=R(K)
   10 R(K)=0.
      IF (ICOUNT.EQ.3) GO TO 40
      IF (KSTEP.EQ.1) GO TO 20
C
C     UPDATE PREVIOUS TIME MODAL DISPLACEMENT PARAMETERS
C
      DO 15 I=1,NMODES
      VEL=XD(I)
      ACC=XDD(I)
      XDD(I)=B0*XI(I) - B2*VEL - B3*ACC
      XD(I)=VEL + B6*ACC + B7*XDD(I)
      X(I)=X(I) + XI(I)
   15 CONTINUE
C
C     INITIALIZE INCREMENTAL DISPLACEMENTS AT THE BEGINNING OF THIS STEP
C
   20 DO 25 I=1,NMODES
      P(I)=0.
   25 XI(I)=0.
      GO TO 50
C
C     IN EQUILIBRIUM ITERATION ADD INCREMENTAL DISPLACEMENT EFFECT
C
   40 DO 45 I=1,NMODES
   45 P(I)=-B0*XI(I) - B1*XSI(I)*XI(I)
C
C     MASS EFFECT
C
   50 DO 55 I=1,NMODES
   55 P(I)=P(I) + B2*XD(I) + B3*XDD(I)
C
C     MODAL DAMPING EFFECT
C
      IF (IMDAMP.EQ.0) GO TO 70
      DO 60 I=1,NMODES
   60 P(I)=P(I) + XSI(I)*(B4*XD(I) + B5*XDD(I))
C
C     STIFFNESS EFFECT
C
   70 IF (KLIN.GT.0) GO TO 90
C
C     LINEAR ANALYSIS
C
      DO 80 I=1,NMODES
   80 P(I)=P(I) - EIGV(I)*X(I)
      GO TO 150
C
C     EFFECT OF LINEAR ELEMENTS IN NONLINEAR ANALYSIS
C
   90 IF (NEGL.EQ.0 .AND. NSUBST.EQ.0) GO TO 150
      IJ=0
      DO 120 I=1,NMODES
      XDUM=X(I) + XI(I)
      DO 120 J=I,NMODES
      IJ=IJ + 1
      P(I)=P(I) - AA(IJ)*(X(J) + XI(J))
      IF (I - J) 110,120,110
  110 P(J)=P(J) - AA(IJ)*XDUM
  120 CONTINUE
C
C     IF ALL EIGENVECTORS CAN BE KEPT IN CORE, READ THEM ONLY ONCE
C
  150 NN=ISTOH
      IF (NBLOCK.GT.1) NN=2*ISTOH
      NVEC=NN/NEQ
      NX=NMODES/NVEC
      IF (NX*NVEC .LT. NMODES) NX=NX + 1
      REWIND NT
      IF (NX.GT.1) GO TO 170
      IF (KSTEP.GT.1 .OR. ICOUNT.EQ.3) GO TO 170
      READ (NT) ((PHI(K,J),K=1,NEQ),J=1,NMODES)
C
C     NVEC IS THE NUMBER OF EIGENVECTORS THAT CAN BE TAKEN INTO CORE
C
  170 NN=1
      DO 300 I=1,NX
      MM=NN + NVEC - 1
      IF (MM.GT.NMODES) MM=NMODES
      JJ=MM - NN + 1
      IF (NX.EQ.1) GO TO 180
      READ (NT) ((PHI(K,J),K=1,NEQ),J=1,JJ)
C
  180 DO 250 J=1,JJ
      KK=NN + J - 1
C
C     PROJECT EXTERNAL LOADS. NOTE THAT IN NONLINEAR ANALYSIS RE VECTOR
C     HAS NONLINEAR CONTRIBUTION ALSO IN IT.
C
      DUM=P(KK)
      DO 200 K=1,NEQ
  200 P(KK)=P(KK) + PHI(K,J)*RE(K)
C
      XII=BETA(KK)*P(KK)
      IF (KLIN.EQ.0) P(KK)=P(KK) - DUM
C
      DO 220 K=1,NEQ
  220 R(K)=R(K) + PHI(K,J)*XII
C
      XI(KK)=XI(KK) + XII
  250 CONTINUE
C
  300 NN=NN + NVEC
C
      PEOLD=0.0
      DO 350 I=1,NMODES
  350 PEOLD=PEOLD + P(I)*XI(I)
C
      IF (ICOUNT.EQ.3) RETURN
      PEINIT=PEOLD
C
      IF (KLIN.EQ.0) WRITE (6,2000) KSTEP
      IF (KLIN.GT.0) WRITE (6,2010) KSTEP
      WRITE (6,2020)
      WRITE (6,2050) (I,P(I),I=1,NMODES)
C
      RETURN
C
C
 2000 FORMAT (///52H PROJECTIONS OF EXTERNAL LOADS ON TO THE MODAL BASIS
     114H FOR STEP NO =,I5 /)
 2010 FORMAT (///65H PROJECTIONS OF INCREMENTAL EFFECTIVE LOADS ON TO TH
     1E MODAL BASIS,14H FOR STEP NO =,I5 /)
 2020 FORMAT (5(6X,4HMODE,7X,6HFACTOR,2X)/)
 2050 FORMAT (5(4X,I5,1X,E15.5)/)
      END
C *CDC* *DECK MODUM1
C *UNI* )FOR,IS N.MODUM1, R.MODUM1
      SUBROUTINE MODUM1
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      RETURN
      END
C *CDC* *DECK MODUM2
C *UNI* )FOR,IS N.MODUM2, R.MODUM2
      SUBROUTINE MODUM2
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      RETURN
      END
