Liren Large Software Subsidy 9

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 9 / 09.iso / e / e001 / 1.ddi / TMP / ADINA42.FOR < prev next >

Wrap

Text File | 1991-01-07 | 220.8 KB | 7,803 lines

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