Liren Large Software Subsidy 9

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

/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 9.ddi / EIGENT1.FOR next >

Wrap

Text File | 1987-06-23 | 105.7 KB | 1,322 lines

SUBROUTINE EIGEN 00067990 IMPLICIT REAL*8 (A-H,O-Z) 00068000 COMMON A(1) 00068010 COMMON /ELPAR/ XP(14),NUMNP,MBAND,NELTYP,N1,N2,N3,N4,N5,MTOT,NEQ 00068020 & ,RRELPA(24) R0068021 COMMON /DYN2/IFPR,IFSS,NITEM,NFO,RTOL,COFQ,DT,ALFA,BETA,NFN,NGM, 00068030 $NAT,NTTT,NOT,NRDYN2(9) R0068040 COMMON/DYN3/ NEIG,NAD,ANORM,NVV,NFQ 00068050 COMMON /DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 00068060 COMMON/SLVE/NSLAVE 00068070 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00068080 COMMON /DYN5/FRSHFT,FRINIT,FREND,MODEFR,NOSS R0068090 COMMON / MISC / NBLOCK,NEQB,LL,NF,LB R0068100 COMMON /QTSARG/ AT(400),RRQTSA(600) R0068110 COMMON /EXTRA/ MODEX,NT8,NREXTR(24) R0068120 COMMON /OUT/IDUMM(4),IOSIG,IODISP,NROUT(4) R0068130 COMMON /HEADIN/TITLE1(20),TITLE2(5),TITLE3(10) 00068140 DIMENSION TT(3) 00068150 CALL FILES(13) 00068160 CALL SECOND (TT(1)) 00068170 WRITE (6,190) 00068180 IF(IABS(KDYN).EQ.11) WRITE(6,270) 00068190 100 IF (MODEX.EQ.1) RETURN 00068200 TPI=6.2831853E0 00068210 NFQ=NFO 00068220 IF (IFPR.GT.0) IFPR=1 00068230 IF (IFSS.GT.0) IFSS=1 00068240 IF (NITEM.EQ.0) NITEM=16 00068250 IF (RTOL.EQ.0.E0) RTOL=1.E-05 00068260 IF (COFQ.EQ.0.E0) COFQ=1.E08 00068270 IF(NEIG.EQ.0) WRITE(6, 170) 00068280 IF(NEIG.GT.0) WRITE(6, 180) 00068290 CALL MODE4 (NEQ,MBAND,NBLOCK,NEQB,NF,MTOT,IFPR,IFSS,RTOL,NITEM, 00068300 $COFQ) 00068310 IF(MODEX.EQ.1) RETURN 00068320 IF(MODEFR.EQ.1) RETURN 00068330 CALL SECOND (TT(2)) 00068340 NZ=NR 00068350 IF(NEIG.EQ.0)NZ=NT 00068360 IF(NCWT.LE.0)GO TO 105 00068370 IF(NRESS1.EQ.0)REWIND NCWT 00068380 WRITE (NCWT) NEQ,NBLOCK,NEQB,MBAND,N1,NF,(AT(I),I=1,NF) 00068390 REWIND NZ 00068400 NWW=NEQB*NF 00068410 READ(NZ) (A(I),I=1,NF) 00068420 WRITE(NCWT) (A(I),I=1,NF) 00068430 DO 103 I=1,NBLOCK 00068440 CALL RDWRT(NZ,A,NWW,14,I) 00068450 CALL RDWRT(NCWT,A,NWW,13,I) 00068460 103 CONTINUE 00068470 WRITE(6,104)NCWT,NF 00068480 104 FORMAT(46H THE CURRENT EIGENSOLUTIONS HAVE BEEN STORED/ 00068490 X 25H ON TAPE, UNIT NUMBER =,I5/ 00068500 X 25H NUMBER OF FREQUENCIES=,I5//) 00068510 105 CONTINUE 00068520 REWIND NZ 00068530 READ (NZ) (A(I),I=1,NF) 00068540 IF(IABS(KDYN).EQ.11) GO TO 1120 00068550 K=NF+1 00068560 DO 110 I=1,NF 00068570 K=K-1 00068580 KK=(K-1)*3+1 00068590 A(KK)=A(K) 00068600 A(KK+1)=A(K)/TPI 00068610 110 A(KK+2)=TPI/A(K) 00068620 IF (NEIG.GT.0) GO TO 130 00068630 WRITE (6,200) 00068640 DO 120 I=1,NF 00068650 K1=3*I-2 00068660 K2=3*I 00068670 120 WRITE (6,220) I,(A(J),J=K1,K2) 00068680 GO TO 150 00068690 130 WRITE (6,210) 00068700 DO 140 I=1,NF 00068710 K1=3*I-2 00068720 K2=3*I 00068730 140 WRITE (6,220) I,(A(J),J=K1,K2),AT(NF+I) 00068740 GO TO 150 00068750 1120 WRITE(6,280) 00068760 DO 1130 I=1,NF 00068770 1130 WRITE(6,290) I,A(I),AT(NF+I) 00068780 150 N2=N1+NUMNP*3 00068790 N3=N2+6*NF 00068800 N4=N3+NEQB*NF 00068810 N5=N4+NSLAVE*4 00068820 IF(N5.GT.MTOT) CALL ERROR(N5-MTOT) 00068830 NSLDM=NSLAVE 00068840 IF(NSLDM.LE.0) NSLDM=1 00068850 IF(IODISP.EQ.1) CALL FCOPY(L5TP6,L6TP50) 00068860 IF(IODISP.EQ.1) TITHOL=TITLE3(3) 00068870 WRITE (6,230) 00068880 CALL PRINT4 (A(N1),A(N2),A(N3),NEQB,NUMNP,NF,NBLOCK,NEQ,NZ,NF,A(1)00068890 $,A(N4),NSLDM) 00068900 IF(IODISP.EQ.1) WRITE(6,260) 00068910 IF(IODISP.EQ.1) WRITE(6,250) 00068920 IF(IODISP.EQ.1) TITLE3(3)= TITHOL 00068930 CALL SECOND (TT(3)) 00068940 DO 160 K=1,2 00068950 160 TT(K) = TT(K+1)-TT(K) 00068960 WRITE (6,240) (TT(L),L=1,2) 00068970 XP(1)=TT(1)+TT(2) 00068980 170 FORMAT (44H0DETERMINANT SEARCH SOLUTION IS CARRIED OUT ) 00068990 180 FORMAT (44H0SUBSPACE ITERATION SOLUTION IS CARRIED OUT ) 00069000 190 FORMAT (1X ,//41H E I G E N V A L U E A N A L Y S I S ) 00069010 200 FORMAT (1X ,20HPRINT OF FREQUENCIES // 00069020 $ 23H MODE CIRCULAR / 00069030 $ 49H NUMBER FREQUENCY FREQUENCY PERIOD /00069040 $ 49H (RAD/SEC) (CYCLES/SEC) (SEC) )00069050 210 FORMAT (1X ,20HPRINT OF FREQUENCIES // 00069060 $ 23H MODE CIRCULAR / 00069070 $ 58H NUMBER FREQUENCY FREQUENCY PERIOD TOL00069080 $ERANCE / 00069090 $ 49H (RAD/SEC) (CYCLES/SEC) (SEC) )00069100 220 FORMAT (1H0,I4,6X,4(E10.4,2X)) 00069110 230 FORMAT (/// 22H PRINT OF EIGENVECTORS, // 1X) 00069120 240 FORMAT (//// 44H E I G E N S O L U T I O N T I M E L O G, 00069130 $ //5X,15HEIGENSOLUTION =, F8.2 / 00069140 $ 5X,15HPRINTING =, F8.2 /) 00069150 250 FORMAT(///20X,32(1H')/20X,32HMODE SHAPES WILL NOT BE PRINTED./20X,00069160 1 31(1H')//) 00069170 260 FORMAT (/) 00069180 270 FORMAT(1H+,42X,39HF O R B U C K L I N G P R O B L E M//) 00069190 280 FORMAT (1X ,22H PRINT OF EIGENVALUES // 00069200 $ 39H MODE EIGENVALUE TOLERANCE) 00069210 290 FORMAT (1H0,I4,6X,E10.4,8X,E10.4) 00069220 RETURN 00069230 END 00069240 SUBROUTINE WRDIS4(NORD,A,B,NUMNP,LL,NDPBLK,NDIS,NBLK 00326130 & ,AD,XXK,ARE,NREL,ISL,NSLDM) 00326140 IMPLICIT REAL*8(A-H,O-Z) 00326150 DIMENSION NORD(NUMNP),A(6,LL),B(NDPBLK,6,LL) 00326160 & ,AD(NUMNP,3),XXK(NREL,6,LL),ARE(51,NREL),DX(3),ISL(NSLDM,4) 00326170 COMMON /OUT/ KDUMMY(9),KROT 00326180 COMMON /BAND/ KOPT,NRBAND(7) R0326190 COMMON/SLVE/NSLAVE 00326200 COMMON /RIGID/ IIA(20),NREX 00326210 NT1=17 00326220 NT2=18 00326230 IF(NSLAVE.NE.0) REWIND 30 00326240 IF(NSLAVE.NE.0) READ(30)((ISL(I,J),J=1,4),I=1,NSLAVE) 00326250 NT40=40 00326260 REWIND 8 00326270 READ(8)AD 00326280 IF(KOPT.GT.0) READ (NT1) NORD 00326290 IF(NREX.LE.0)GO TO 10 00326300 REWIND NT40 00326310 READ(NT40)ARE 00326320 REWIND NT2 00326330 K=NUMNP+1 00326340 DO 8 JJ=1,NUMNP 00326350 K=K-1 00326360 KK=K 00326370 IF(KOPT.GT.0)KK=NORD(K) 00326380 DO 7 J=1,NREX 00326390 NN=ARE(2,J) 00326400 IF(KK.NE.NN)GO TO 7 00326410 READ(NT2)A 00326420 DO 5 M=1,6 00326430 DO 5 L=1,LL 00326440 5 XXK(J,M,L)=A(M,L) 00326450 GO TO 8 00326460 7 CONTINUE 00326470 READ(NT2) 00326480 8 CONTINUE 00326490 10 CONTINUE 00326500 KSHF2=0 00326510 KSHF=1-NDPBLK 00326520 KNT=0 00326530 DO 140 I=1,NBLK 00326540 REWIND NT2 00326550 KOUNT=0 00326560 KK=NUMNP+1 00326570 KSHF=KSHF+NDPBLK 00326580 KSHF2=KSHF2+NDPBLK 00326590 DO 110 JJ=1,NUMNP 00326600 KK=KK-1 00326610 READ (NT2) A 00326620 KCH= KK 00326630 IF(KOPT.GT.0) KCH=NORD(KK) 00326640 IF(KCH.LT.KSHF.OR.KCH.GT.KSHF2) GO TO 110 00326650 KNT=KNT+1 00326660 KOUNT=KOUNT+1 00326670 NSHFT=KCH-KSHF+1 00326680 DO 100 K=1,6 00326690 DO 100 M=1,LL 00326700 100 B(NSHFT,K,M)=A(K,M) 00326710 IF(NREX.LE.0)GO TO 109 00326720 DO 108 J=1,NREX 00326730 NN=ARE(1,J)+1 00326740 NK=ARE(2,J) 00326750 DO 107 K=3,NN 00326760 N=ARE(K,J) 00326770 IF(N.NE.NSHFT)GO TO 107 00326780 DO 101 M=4,6 00326790 DO 101 L=1,LL 00326800 101 B(NSHFT,M,L)=XXK(J,M,L) 00326810 NQA=NSHFT 00326820 NQB=NK 00326830 IF(KOPT.LE.0)GO TO 1015 00326840 DO 1010 L=1,NUMNP 00326850 IF(NORD(L).NE.NSHFT)GO TO 1009 00326860 NQA=L 00326870 1009 IF(NORD(L).NE.NK)GO TO 1010 00326880 NQB=L 00326890 1010 CONTINUE 00326900 1015 CONTINUE 00326910 DO 102 M=1,3 00326920 CALL UNPKID(AD,NUMNP,X,XJ,1,NQA,M) 00326930 CALL UNPKID(AD,NUMNP,X,XK,1,NQB,M) 00326940 102 DX(M)=XK-XJ 00326950 DO 104 L=1,LL 00326960 B(NSHFT,1,L)=XXK(J,1,L)-XXK(J,5,L)*DX(3)+XXK(J,6,L)*DX(2) 00326970 B(NSHFT,2,L)=XXK(J,2,L)+XXK(J,4,L)*DX(3)-XXK(J,6,L)*DX(1) 00326980 B(NSHFT,3,L)=XXK(J,3,L)-XXK(J,4,L)*DX(2)+XXK(J,5,L)*DX(1) 00326990 104 CONTINUE 00327000 GO TO 109 00327010 107 CONTINUE 00327020 108 CONTINUE 00327030 109 CONTINUE 00327040 IF(NSLAVE.EQ.0) GO TO 1200 00327050 DO 1120 J=1,NSLAVE 00327060 IF(KK.EQ.ISL(J,1)) GO TO 1130 00327070 1120 CONTINUE 00327080 GO TO 1200 00327090 1130 CONTINUE 00327100 ISLRF=J 00327110 DO 1180 J=1,3 00327120 NMAST=MOD(ISL(ISLRF,J+1),10000) 00327130 IF(NMAST.EQ.0) GO TO 1180 00327140 DO 1160 M=1,3 00327150 CALL UNPKID(AD,NUMNP,X,XJ,1,NMAST,M) 00327160 CALL UNPKID(AD,NUMNP,X,XK,1,KK,M) 00327170 1160 DX(M)=XK-XJ 00327180 DO 1170 L=1,LL 00327190 IF(J.EQ.1) B(NSHFT,1,L)=B(NSHFT,1,L)+DX(3)*B(NSHFT,5,L) 00327200 1 -DX(2)*B(NSHFT,6,L) 00327210 IF(J.EQ.2) B(NSHFT,2,L)=B(NSHFT,2,L)-DX(3)*B(NSHFT,4,L) 00327220 1 +DX(1)*B(NSHFT,6,L) 00327230 IF(J.EQ.3) B(NSHFT,3,L)=B(NSHFT,3,L)+DX(2)*B(NSHFT,4,L) 00327240 1 -DX(1)*B(NSHFT,5,L) 00327250 1170 CONTINUE 00327260 1180 CONTINUE 00327270 1200 CONTINUE 00327280 IF(KOUNT.EQ.NDPBLK.OR.KNT.EQ.NUMNP) GO TO 120 00327290 110 CONTINUE 00327300 120 KNT1=(I-1)*NDPBLK 00327310 DO 130 J=1,NDPBLK 00327320 KNT1=KNT1+1 00327330 IF(KNT1.GT.NUMNP) GO TO 150 00327340 WRITE(6,160)KNT1,(M,(B(J,K,M),K=1,6),M=1,LL) 00327350 IF(NDIS.GT.0) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=1,3),M=1,LL) 00327360 IF(NDIS.GT.0.AND.KROT.EQ.2) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=400327370 $,6),M=1,LL) 00327380 DO 125 M=1,LL 00327390 125 WRITE(32,200)KNT1,M,(B(J,K,M),K=1,6) 00327400 200 FORMAT(2I5,6F20.10) 00327410 130 CONTINUE 00327420 140 CONTINUE 00327430 150 IF(KOPT.GT.0) WRITE(6,180) 00327440 160 FORMAT(1H0,I4,I5,1P3E12.3,3E11.2/(I10,3E12.3,3E11.2)) 00327450 170 FORMAT(I10,7E10.4/(8E10.4)) 00327460 180 FORMAT(// 3X,46H*** NOTE *** NODE NUMBERS ARE ORIGINAL NUMBERS //)00327470 RETURN 00327480 END 00327490 SUBROUTINE PRINT4(ID,D,B,NEQB,NUMNP,LL,NBLOCK,NEQ,NT,NF,DIS,ISL, 00175920 1NSLDM) 00175930 IMPLICIT REAL*8(A-H,O-Z) 00175940 REAL*8 ID 00175950 COMMON/PREP/XMX,XAD,KSKIP,NDYN,I1,RRPREP(7) R0175960 COMMON /OUT/NRES,NSTR,NDIS,NROUT(7) R0175970 DIMENSION DIS(10,LL),ISL(NSLDM,4) 00175980 COMMON /QTSARG/ NEQ3(10),RRQTSA(995) R0175990 COMMON /GPS/ NEQ4(10),NRGPS(10) R0176000 COMMON/SLVE/NSLAVE 00176010 COMMON /ELPAR/ XPAR(14),NDUM(8),MTOT 00176020 $,IZX(6),NUMEL,NUMEL2,NRELPA(41) R0176030 COMMON/RIGID/IIA(20),NREX 00176040 COMMON A(1) 00176050 DIMENSION ID(NUMNP,3),B(NEQB,LL),D(6,LL) 00176060 IF(NDIS.LT.0) RETURN 00176070 REWIND NT 00176080 IF(NF.GT.0) READ (NT) 00176090 REWIND 8 00176100 READ (8) ID 00176110 IF(NSLAVE.NE.0) REWIND 30 00176120 IF(NSLAVE.NE.0) READ(30)((ISL(I,J),J=1,4),I=1,NSLAVE) 00176130 REWIND 17 00176140 REWIND 18 00176150 NREL=NREX 00176160 IF(NREL.LE.0)NREL=1 00176170 NDPBLK=(MTOT-(16*LL)-4*NUMNP-(6*LL+51)*NREL-NSLDM*4)/(6*LL) 00176180 NBLK= (NUMNP-1)/NDPBLK+1 00176190 KK=1 00176200 NFIL=1 00176210 IF(NDIS.GT.0) WRITE(NDIS,7123)NFIL,LL,NDYN,NDIS,NSTR,NUMNP,NUMEL,N00176220 $UMEL2 00176230 7123 FORMAT(2I5,5X,7I5) 00176240 M=NEQ 00176250 NN=NEQB*NBLOCK 00176260 IF(NF.EQ.0) WRITE (6,220) 00176270 IF(NF.GT.0) WRITE (6,240) 00176280 N=NUMNP 00176290 DO 100 I=1,10 00176300 100 NEQ3(I)=0 00176310 DO 210 KK=1,NUMNP 00176320 I=6 00176330 DO 190 II=1,6 00176340 DO 110 L=1,LL 00176350 110 D(I,L)=0. 00176360 IF(M.GT.NN) GO TO 120 00176370 IF (M.EQ.0) GO TO 120 00176380 READ (NT) B 00176390 NN=NN-NEQB 00176400 K=M-NN 00176410 ND=0 00176420 120 CALL UNPKID ( ID ,NUMNP,W ,WX ,2,N,I) 00176430 NNN=W 00176440 IF(NNN.LT.1) GO TO 190 00176450 K=M-NN 00176460 KI=0 00176470 DO 130 L=1,10 00176480 IF(NNN.EQ.NEQ4(L)) KI=L 00176490 130 CONTINUE 00176500 IF(KI.EQ.0) GO TO 160 00176510 IF(NEQ3(KI).GT.0) GO TO 140 00176520 K=K-M+NNN 00176530 IF(K.LT.0) GO TO 140 00176540 NEQ3(KI)=1 00176550 IF(NNN.EQ.M) M=M-1 00176560 GO TO 170 00176570 140 DO 150 L=1,LL 00176580 150 D(I,L)=DIS(KI,L) 00176590 IF(NNN.EQ.M) M=M-1 00176600 GO TO 190 00176610 160 CONTINUE 00176620 IF(NSLAVE.EQ.0) GO TO 168 00176630 DO 163 J=1,NSLAVE 00176640 IF(N.EQ.ISL(J,1)) GO TO 164 00176650 163 CONTINUE 00176660 GO TO 168 00176670 164 CONTINUE 00176680 IRK=I 00176690 IF(IRK.LE.3) NMAST=MOD(ISL(J,IRK+1),10000) 00176700 IF(IRK.GT.3) NMAST=ISL(J,IRK-2)/10000 00176710 IF(NMAST.EQ.0) GO TO 168 00176720 NEND=NN+NEQB+1 00176730 IF(NNN.LE.NN) GO TO 1170 00176740 IF(NNN.GE.NEND) GO TO 1195 00176750 KI=NNN-NN 00176760 DO 165 L=1,LL 00176770 165 D(I,L)=B(KI,L) 00176780 GO TO 190 00176790 1170 NNRK=NN 00176800 1175 NNRK=NNRK-NEQB 00176810 NENDRK=NNRK+NEQB+1 00176820 READ (NT) B 00176830 IF (NNN.LE.NNRK) GO TO 1175 00176840 KI=NNN-NNRK 00176850 DO 1180 L=1,LL 00176860 1180 D(I,L)=B(KI,L) 00176870 IF(NN.EQ.NNRK) GO TO 190 00176880 REWIND NT 00176890 NNRK=NEQB*NBLOCK 00176891 READ (NT) 00176900 GO TO 1230 00176910 1195 REWIND NT 00176920 READ (NT) 00176930 NNRK=NEQB*NBLOCK 00176940 1200 NNRK=NNRK-NEQB 00176950 READ(NT) B 00176960 IF(NNN.LE.NNRK) GO TO 1200 00176970 KI=NNN-NNRK 00176980 DO 1220 L=1,LL 00176990 1220 D(I,L)=B(KI,L) 00177000 IF(NN.EQ.NNRK) GO TO 190 00177010 1230 NNRK=NNRK-NEQB 00177020 NENDRK=NNRK+NEQB+1 00177030 READ (NT) 00177040 IF(NN.EQ.NNRK) GO TO 190 00177050 GO TO 1230 00177060 168 CONTINUE 00177070 M=M-1 00177080 170 KND=K-ND 00177090 DO 180 L=1,LL 00177100 IF(KI.EQ.0) GO TO 180 00177110 DIS(KI,L)=B(KND,L) 00177120 180 D(I,L)=B(KND,L) 00177130 190 I=I-1 00177140 200 FORMAT (2I5) 00177150 WRITE (18) D 00177160 210 N=N-1 00177170 K=1+10*LL 00177180 N2=K+NUMNP 00177190 N3=N2+6*LL 00177200 N4=N3+6*LL*NDPBLK 00177210 N5=N4+NUMNP*3 00177220 N6=N5+NREL*6*LL 00177230 N7=N6+51*NREL 00177240 N8=N7+NSLAVE*4 00177250 IF(N8.GT.MTOT) CALL ERROR(N8-MTOT) 00177260 CALL WRDIS4(A(K),A(N2),A(N3),NUMNP,LL,NDPBLK,NDIS,NBLK 00177270 & ,A(N4),A(N5),A(N6),NREL,A(N7),NSLDM) 00177280 RETURN 00177290 220 FORMAT (40H1.......NODE DISPLACEMENTS AND ROTATIONS// 00177300 $ 5H NODE, 5H LOAD ,11X, 1HX, 11X, 1HY, 11X ,1HZ ,9X, 2HXX, 00177310 $ 9X, 2HYY, 9X, 2HZZ) 00177320 230 FORMAT (1H0,I4,I5,1P3E12.3,3E11.2/(I10,3E12.3,3E11.2)) 00177330 240 FORMAT (19H1.......MODE SHAPES // 00177340 $ 5H0NODE, 5H MODE, 11X, 1HX, 11X, 1HY, 11X, 1HZ, 9X ,2HXX, 00177350 $ 9X, 2HYY, 9X, 2HZZ) 00177360 250 FORMAT (I10,7E10.4/(8E10.4)) 00177370 END 00177380 SUBROUTINE MODE4 (NEQ,MBAND,NBLOCK,NEQB,NF,MTOT,IFPR,IFSS,RTOL, 00137150 $NITEM,COFQ) 00137160 IMPLICIT REAL*8 (A-H,O-Z) 00137170 COMMON /EXTRA/ MODEX,NREXTR(25) R0137180 COMMON/DYN3/ NEIG,NAD,ANORM,NVV,NFO 00137190 COMMON /DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 R0137200 COMMON/MASS/LMASS 00137210 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00137220 COMMON /SSIT/ NV 00137230 CC COMMON /AAA1/AAR(8000) R0137231 COMMON A(1) 00137240 IF (NEIG.GT.0) GO TO 120 00137250 IF(NVV.GE.NF) GO TO 100 00137260 WRITE (6,160) NF,NVV 00137270 MODEX=1 00137280 RETURN 00137290 100 CONTINUE 00137300 NIM=3 00137310 NVM=6 00137320 NC=NF+NIM 00137330 NCA=NEQ*MAX0(MBAND,NC) 00137340 N2=1 + NCA R0137350 N3=N2+NEQ 00137360 IF(LMASS.EQ.1) N3=N2+NEQ*MBAND 00137370 N4=N3+NEQ 00137380 N5=N4+NEQ 00137390 N6=N5+NEQ 00137400 N7=N6+NEQ*NVM 00137410 N8=N7+NEQ*NVM 00137420 N9=N8+NC 00137430 N10=N9+NC 00137440 N11=N10+NC 00137450 N12=N11+NC 00137460 110 CONTINUE 00137470 CALL SECANT (A(1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),A(N900137480 $),A(N10),A(N11),A(N12),NEQ,MBAND,NF,NC,IFPR,ANORM,COFQ) 00137490 IF(MODEX.EQ.1) RETURN 00137500 GO TO 150 00137510 120 NWA=NEQB*MBAND 00137520 NV=2*NF 00137530 IF (NF.GT.8) NV=NF+8 00137540 IF (NAD.NE.0) NV=NAD 00137550 IF(NV.GT.NVV.AND.IABS(KDYN).EQ.11) NV=NVV 00137560 IF(NF.EQ.1.AND.IABS(KDYN).EQ.11) NV=NF 00137570 IF (NVV.GE.NV) GO TO 130 00137580 WRITE (6,160) NV,NVV 00137590 MODEX=1 00137600 RETURN 00137610 130 NWV=NV*NEQB 00137620 NTB=(MBAND-2)/NEQB+1 00137630 IF (NTB.GE.NBLOCK) NTB=NBLOCK-1 00137640 NWVV=NWV*(NTB+1) 00137650 IF(NCRD.LE.0)GO TO 140 00137660 IF(NRESS.EQ.0)REWIND NCRD 00137670 READ (NCRD) NEQO,MBLOCK ,NEQBO,MBANDO,N1O,NFO 00137680 MMA=1 00137690 IF(LMASS.EQ.1) MMA=MBAND 00137700 N2=1+NEQBO*NFO 00137710 N3=N2+NEQB*NV 00137720 N4=N3+NEQB*MMA 00137730 CALL SBLOCK(A(1),A(N2),A(N3),A(N4),NFO,NV,NEQBO,NEQB,MBLOCK,NBLOCK00137740 $,MMA,NEQ,NEQO) 00137750 140 CONTINUE 00137760 CALL SSPACE (NEQ,MBAND,NBLOCK,NEQB,NF,NV,NWA,NWV,NWVV,NTB,IFPR, 00137770 $IFSS,NITEM,RTOL,ANORM,COFQ) 00137780 150 RETURN 00137790 160 FORMAT (/// 32H0***ERROR SOLUTION TERMINATED., / 00137800 $ 12X,40HNUMBER OF NON-ZERO MASSES REQUIRED =, I5 / 00137810 $ 12X,40HNUMBER OF EXISTING MASSES IN THE MODEL =, I5 ) 00137820 END 00137830 DOUBLE PRECISION FUNCTION MODUE (T,M) 00150250 IMPLICIT REAL*8(A-H,O-Z) 00150260 COMMON/MATL/MATLCO 00150270 DATA NHIGH/4HHIGH/ R0150280 IF(MATLCO.NE.NHIGH)GO TO 10 00150290 CALL MODUE2 (T,M,X) 00150300 MODUE=X*1.0D6 00150310 RETURN 00150320 10 CALL MODUE1 (T,M,X) 00150330 MODUE=X*1.0D6 00150340 RETURN 00150350 END 00150360 SUBROUTINE BANDET (A,B,V,MAXA,NN,NWA,RA,NSCH,DET,ISCALE,KK) 0021770 IMPLICIT REAL*8 (A-H,O-Z) 00021780 COMMON /EXTRA/ MODEX,NREXTR(25) R0021790 COMMON /MASS/ LMASS 00021800 COMMON /TAPES/NSTIF,NRTAPE(5) R0021810 DIMENSION A(NWA),B(1),V(1),MAXA(1) 00021820 NR=NN-1 00021830 IF (KK-2) 100,360,400 00021840 100 TOL=1.0E+07 00021850 RTOL=1.0E-10 00021860 IPOW=80 00021870 USCALE=2.D0**IPOW 00021880 BSCALE=2.D0**(-IPOW) 00021890 DET=1.0D0 00021900 ISCALE=0 00021910 NTF=3 00021920 IS=1 00021930 110 CALL RDWRT(NSTIF,A,1,6,I) 00021940 CC CALL EXPAND(A,NWA,NSTIF) 00021950 READ (NSTIF) (A(IIR),IIR=1,NWA) R0021951 IF(LMASS.EQ.1) GO TO 120 00021960 CALL QMR2(A(1),A(1),RA,B(1),NN,1,1,1) 00021970 GO TO 130 00021980 120 CALL QMR3(A(1),A(1),RA,B(1),NN,1,1,1,NWA) 00021990 130 IF (NWA.EQ.NN) GO TO 280 00022000 DO 270 N=1,NR 00022010 IH=N+NWA-NN 00022020 140 IF (A(IH)) 160,150,160 00022030 150 IH=IH-NN 00022040 GO TO 140 00022050 160 MAXA(N)=IH 00022060 PIV=A(N) 00022070 IF(PIV) 200,170,200 00022080 170 IS = IS+1 00022090 IF(IS.LE.NTF) GO TO 190 00022100 180 WRITE (6,450) NTF,RA 00022110 MODEX=1 00022120 RETURN 00022130 190 RA = RA*(1.0E0-RTOL) 00022140 GO TO 110 00022150 200 IL=N+NN 00022160 L=N 00022170 DO 260 I=IL,IH,NN 00022180 L=L+1 00022190 C=A(I) 00022200 IF (C) 210,260,210 00022210 210 C=C/PIV 00022220 IF ( DABS(C).LT.TOL) GO TO 240 00022230 220 IS=IS+1 00022240 IF (IS.LE.NTF) GO TO 230 00022250 GO TO 180 00022260 230 RA=RA*(1.0E0-RTOL) 00022270 GO TO 110 00022280 240 J=L-I 00022290 CALL QMR2(A(L),A(L),C,A(I),(IH-I)/NN+1,NN,NN,NN) 00022300 A(I)=C 00022310 260 CONTINUE 00022320 270 CONTINUE 00022330 280 IF (A(NN).NE.0.0E0) GO TO 300 00022340 AA= DABS(A(1)) 00022350 DO 290 I=2,NR 00022360 290 AA=AA+ DABS(A(I)) 00022370 A(NN)=-(AA/NR)*1.0D-14 00022380 300 NSCH=0 00022390 ISC=0 00022400 DET=1.0E0 00022410 DO 320 I=1,NN 00022420 310 DET=DET*A(I) 00022430 IF(DET.LT.USCALE.AND.DET.GE.BSCALE) GO TO 320 00022440 CALL RSC(DET,ISCALE) 00022450 320 IF (A(I).LT.0.E0) NSCH=NSCH+1 00022460 RETURN 00022470 360 IL=NN 00022480 DO 390 N=1,NR 00022490 C=V(N) 00022500 V(N)=C/A(N) 00022510 IF (NWA-NN) 370,390,370 00022520 370 IL=IL+1 00022530 IH=MAXA(N) 00022540 K=N 00022550 NP1=N+1 00022560 CALL QMR2(V(NP1),V(NP1),C,A(IL),(IH-IL)/NN+1,1,1,NN) 00022570 390 CONTINUE 00022580 V(NN)=V(NN)/A(NN) 00022590 400 IF (NWA-NN) 410,440,410 00022600 410 N=NN 00022610 DO 430 L=2,NN 00022620 N=N-1 00022630 IL=N+NN 00022640 IH=MAXA(N) 00022650 K=N 00022660 DO 420 I=IL,IH,NN 00022670 K=K+1 00022680 420 V(N)=V(N)-A(I)*V(K) 00022690 430 CONTINUE 00022700 440 RETURN 00022710 450 FORMAT (37H0***ERROR SOLUTION STOP IN *BANDET*, / 12X, 00022720 $ 1H(,I3,37H) TRIANGULAR FACTORIZATIONS ATTEMPTED, / 12X, 00022730 $ 16HCURRENT SHIFT = ,E20.14 / 1X) 00022740 END 00022750 SUBROUTINE SBLOCK(VOLD,VNEW,XM,VR,NFO,NV,NEQBO,NEQB,MBLOCK,NBLOCK,00221890 $MMA,NEQ,NEQO) 00221900 IMPLICIT REAL*8 (A-H,O-Z) 00221910 COMMON /TAPES/ NSTIF,NRED,NL,NR,NT,NMASS 00221920 COMMON /DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 R0221930 COMMON/MASS/LMASS 00221940 CC COMMON /AAA1/ VOLD(200,40) R0221941 DIMENSION VOLD(NEQBO,NFO),VNEW(NEQB,NV),XM(NEQB,MMA) R0221950 DIMENSION VR(NEQB,NV) 00221960 LRDS=NEQB*4*(MMA+1) 00221970 LBKS=NEQB*4*MMA 00221980 LNCRDR=NEQBO*NFO*4 00221990 NWDSV=NEQB*NV 00222000 NWDSV=NEQB*NV 00222010 NWMA=NEQB*MMA 00222020 IF(LMASS.NE.1) GO TO 50 00222030 WRITE(6,998) 00222040 998 FORMAT(5X,14HVOLD IN SBLOCK) 00222050 JJO=0 00222060 JJ=0 00222070 INO=0 00222080 NEQBLN=NEQ-NEQB*(NBLOCK-1) 00222090 NEQBLO=NEQO-NEQBO*(MBLOCK-1) 00222100 1120 RRSB = 0.0D0 R0222101 CALL MEMSET(RRSB ,VNEW(1,1),NWDS) R0222110 INN=NEQB 00222120 1150 IF(INO.EQ.0) GO TO 1180 00222130 GO TO 1200 00222140 1180 CONTINUE 00222150 1190 CONTINUE 00222160 JJ0=JJ0+1 00222170 IF(JJO.GT.MBLOCK) GO TO 1300 00222180 READ(NCRD) VOLD 00222190 INO=NEQBO 00222200 IF(JJO.NE.1) GO TO 1220 00222210 NN1=INO-NEQBLO 00222220 NN2=INN-NEQBLN 00222230 INO=INO-NN1+NN2 00222240 1220 CONTINUE 00222250 1230 IF(INN.EQ.0) GO TO 1250 00222260 IF(INO.GT.NEQBO) GO TO 1245 00222270 1200 DO 1240 J=1,NFO 00222280 VNEW(INN,J)=VOLD(INO,J) 00222290 1240 CONTINUE 00222300 1245 INN=INN-1 00222310 INO=INO-1 00222320 IF(INO.EQ.0.AND.INN.NE.0) GO TO 1190 00222330 GO TO 1230 00222340 1250 WRITE(NL)VNEW 00222350 JJ=JJ+1 00222360 GO TO 1120 00222370 1300 CONTINUE 00222380 CALL GDYNIN(VNEW,NV,NBLOCK,NEQB,18,NL) 00222390 CALL QMBAND(XM,VNEW,VR(1,1),VR(1,1),VR(1,1),NEQB,MMA,NV,NBLOCK, 00222400 1NWMA,NEQ,NMASS,18,23,24,NT) 00222410 RETURN 00222420 50 CONTINUE 00222430 DO 100 L=1,MBLOCK 00222440 READ (NCRD) 00222450 100 CONTINUE 00222460 KBLOCK=1 00222470 LBLOCK=0 00222480 I=0 00222490 K=0 00222500 REWIND NMASS 00222510 READ (NMASS) XM 00222520 REWIND NT 00222530 BACKSPACE NCRD 00222540 READ (NCRD) VOLD 00222550 BACKSPACE NCRD 00222560 GO TO 160 00222570 110 K=K+1 00222580 I=I+1 00222590 XMM=XM(I,1) 00222600 DO 120 J=1,NFO 00222610 120 VNEW(I,J)=VOLD(K,J)*XMM 00222620 IF (K.LT.NEQBO) GO TO 140 00222630 K=0 00222640 KBLOCK=1+KBLOCK 00222650 IF(KBLOCK -MBLOCK ) 130,130,150 00222660 130 BACKSPACE NCRD 00222670 READ (NCRD) VOLD 00222680 BACKSPACE NCRD 00222690 140 IF (I.LT.NEQB) GO TO 110 00222700 I=0 00222710 READ (NMASS) XM 00222720 150 LBLOCK=LBLOCK+1 00222730 WRITE (NT) VNEW 00222740 IF (LBLOCK.EQ.NBLOCK) RETURN 00222750 160 RRSB = 0.0D0 R0222751 CALL MEMSET(RRSB ,VNEW(1,1),NWDSV) R0222760 GO TO 110 00222770 END 00222780 SUBROUTINE GDYNIN(VL,NV,NBLOCK,NEQB,N18,NL) 00104670 IMPLICIT REAL*8 (A-H,O-Z) 00104680 DIMENSION VL(NEQB,NV) 00104690 LNLRC=NEQB*NV*4 00104700 REWIND NL 00104710 REWIND N18 00104720 DO 90 I=1,NBLOCK 00104730 90 READ (NL) 00104740 DO 100 I=1,NBLOCK 00104750 BACKSPACE NL 00104760 READ (NL) VL 00104770 BACKSPACE NL 00104780 100 WRITE (N18) VL 00104790 RETURN 00104800 END 00104810 SUBROUTINE QMBAND(B,V,A,C,D,NEQB,MBAND,NF,NBLOCK,NWMA,NEQ 00185790 1,NMASS,NL,MM1,MM2,NT) 00185800 IMPLICIT REAL*8(A-H,O-Z) 00185810 DIMENSION B(NEQB,MBAND),V(NEQB,NF),A(NEQB,NF) 00185820 $,C(NEQB,NF),D(NEQB,NF) 00185830 NUM=NWMA 00185840 N1=MM1 00185850 N2=MM2 00185860 CALL RDWRT(N1 ,A,1,6,I) 00185870 CALL RDWRT(N2 ,A,1,6,I) 00185880 CALL RDWRT(NMASS,A,1,6,I) 00185890 REWIND NL 00185900 NEQBL=NEQ-(NBLOCK-1)*NEQB 00185910 NTB=(MBAND-2)/NEQB+1 00185920 IF (NTB.GE.NBLOCK) NTB=NBLOCK-1 00185930 DO 1000 N=1,NBLOCK 00185940 NEQBB=NEQB 00185950 DO 90 I=1,NEQBB 00185960 DO 90 J=1,NF 00185970 C(I,J)=0.0E0 00185980 D(I,J)=0.0E0 00185990 90 A(I,J)=0.0E0 00186000 IF(N.EQ.1) GO TO 500 00186010 100 IF(NTB.LT.1) GO TO 300 00186020 NMBEG=N-NTB 00186030 IF(NMBEG.LE.0) NMBEG=1 00186040 NMEND=N-1 00186050 NTEMP=NMBEG-1 00186060 IF(NTEMP.EQ.0) GO TO 230 00186070 DO 220 J=1,NTEMP 00186080 READ(NL) V 00186090 220 CONTINUE 00186100 230 CONTINUE 00186110 MM=NMEND-NMBEG+1 00186120 DO 260 NN=NMBEG,NMEND 00186130 READ(NL)V 00186140 READ (N1) B 00186150 DO 250 I=1,NEQBB 00186160 DO 250 J=1,NF 00186170 M=MM*NEQBB+I 00186180 DO 240 K=1,NEQBB 00186190 IF(M.GT.MBAND) GO TO 240 00186200 A(I,J)=A(I,J)+B(K,M)*V(K,J) 00186210 240 M=M-1 00186220 250 CONTINUE 00186230 MM=MM-1 00186240 NTEMP=N-NN 00186250 1992 FORMAT(5X,10E12.5) 00186260 IF(NTEMP.GE.NTB) GO TO 260 00186270 WRITE (N2) B 00186280 260 CONTINUE 00186290 300 CONTINUE 00186300 500 CONTINUE 00186310 READ(NMASS) B 00186320 READ(NL) V 00186330 DO 570 I=1,NEQBB 00186340 DO 570 J=1,NF 00186350 DO 550 K=1,NEQBB 00186360 IF(K.GT.MBAND) GO TO 550 00186370 KK=I+K-1 00186380 IF(KK.GT.NEQBB) GO TO 550 00186390 C(I,J)=C(I,J)+B(I,K)*V(KK,J) 00186400 550 CONTINUE 00186410 IF(I.EQ.1) GO TO 570 00186420 IF(NEQBB.EQ.1) GO TO 570 00186430 KK=I-1 00186440 L=I-NEQBB+1 00186450 IF(L.LT.1) L=1 00186460 M=I 00186470 DO 560 K=L,KK 00186480 IF(M.GT.MBAND) GO TO 560 00186490 C(I,J)=C(I,J)+B(K,M)*V(K,J) 00186500 560 M=M-1 00186510 570 CONTINUE 00186520 IF(NTB.LT.1) GO TO 900 00186530 IF(N.EQ.NBLOCK) GO TO 930 00186540 NTBB=NTB 00186550 NTEMP=NTB+N 00186560 IF(NTEMP.LE.NBLOCK) GO TO 580 00186570 NTBB=NBLOCK-N 00186580 580 CONTINUE 00186590 DO 650 NN=1,NTBB 00186600 READ (NL) V 00186610 DO 600 I=1,NEQBB 00186620 DO 600 J=1,NF 00186630 DO 590 K=1,NEQBB 00186640 KK=NN*NEQBB+K-I+1 00186650 IF(KK.GT.MBAND) GO TO 590 00186660 D(I,J)=D(I,J)+B(I,KK)*V(K,J) 00186670 590 CONTINUE 00186680 600 CONTINUE 00186690 650 CONTINUE 00186700 900 CONTINUE 00186710 REWIND NL 00186720 WRITE (N2) B 00186730 930 CONTINUE 00186740 WRITE (NT) A 00186750 M=N2 00186760 N2=N1 00186770 N1=M 00186780 CALL RDWRT(N1,A,1,6,I) 00186790 CALL RDWRT(N2,A,1,6,I) 00186800 1000 CONTINUE 00186810 RETURN 00186820 END 00186830 SUBROUTINE SECANT (A,B,V,MAXA,W,VV,WW,ROOT,TIM,ERRVL,ERRVR, 00229210 $NITE,N,MA,NROOT,NC,IFPR,ANORM,COFQ) 00229220 IMPLICIT REAL*8 (A-H,O-Z) 00229230 COMMON /EXTRA/ MODEX,NREXTR(25) R0229240 COMMON/DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 R0229250 COMMON /DYN5/ FRSHFT,RRDYN5(3) R0229260 COMMON/MASS/LMASS 00229270 CC COMMON /AAA1/ A(200,40) R0229271 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00229280 DIMENSION A(N,NC),B(N,NC),V(N),W(N),VV(N,6),WW(N,6),ROOT(NC), 00229290 $TIM(NC),ERRVL(NC),ERRVR(NC) R0229300 INTEGER NITE(200),MAXA(N) R0229310 COMMON /QTSARG/ AT(400),RRQTSA(600) R0229320 IFPR = 1 R0229321 ACTOL=1.0D-04 00229330 RCBTOL=1.D-05 00229340 RTOL=1.0D-10 00229350 FACT=1.0D-3 00229360 RQTOL=1.0D-12 00229370 RITOL=1.0D-6 00229380 NC1=NC+1 00229390 NTF=5 00229400 IITEM=10 00229410 NITEM=20 00229420 NITEMM=59 00229430 NVM=6 00229440 REWIND NT 00229450 REWIND NMASS 00229460 IF(LMASS.EQ.1) GO TO 50 00229470 READ (NMASS)(B(I,1),I=1,N) 00229480 GO TO 60 00229490 50 READ (NMASS) ((B(I,J),I=1,N),J=1,MA) 00229500 60 CONTINUE 00229510 ETA=2.0E0 00229520 NOV=0 00229530 JR=1 00229540 NSK=0 00229550 NWA=N*MA 00229560 ISC=1000 00229570 MMA=1 00229580 IF(LMASS.EQ.1) MMA=MA 00229590 NMWA=N*MMA 00229600 IF (N.GT.1) GO TO 110 00229610 IF(B(1,1).GT.0.E0) GO TO 100 00229620 WRITE(6,1000) 00229630 STOP 00229640 100 CALL RDWRT(NSTIF,A,1,6,I) 00229650 CC CALL EXPAND(A,2 ,NSTIF) 00229660 READ (NSTIF) (A(II,1),II=1,2) R0229661 ROOT(1)=A(1,1)/B(1,1) 00229670 NSCH=1 00229680 IF(IABS(KDYN).EQ.11) A(1,1)=1.0D0/DSQRT(DABS(B(1,1))) 00229690 IF(IABS(KDYN).EQ.11) GO TO 760 00229700 A(1,1)= 1.E0/ DSQRT(B(1,1)) 00229710 GO TO 760 00229720 110 CALL SECOND(TIM1) 00229730 RA=0.0E0 00229740 RR=0.0E0 00229750 CALL RDWRT(NSTIF,A,1,6,I) 00229760 CC CALL EXPAND(A,NWA,NSTIF) 00229770 WRITE (6,1001) N,NC,NSTIF 1001 FORMAT (5X,'*** N NC NSTIF IN SECANT ***',3I5/) READ (NSTIF) ((A(II,JJ),II=1,N),JJ=1,MA) R0229771 DO 115 I=1,N 00229780 IF(A(I,1).NE.0.0) GO TO 115 00229790 WRITE(6,114)I 00229800 114 FORMAT(20X,8HEQUATION,I5,13H IS SINGULAR.//) 00229810 MODEX=1 00229820 A(I,1)=1.0 00229830 115 V(I)=B(I,1)/A(I,1) 00229840 IF(MODEX.EQ.1) RETURN 00229850 DO 118 J=3,NC1 00229860 IMAX=0.0 00229870 RMAX=0.0 00229880 DO 117 I=1,N 00229890 IF(V(I).LT.RMAX) GO TO 117 00229900 RMAX=V(I) 00229910 IMAX=I 00229920 117 CONTINUE 00229930 NITE(J)=IMAX 00229940 118 V(IMAX)=0.0 00229950 CALL BANDET(A,B,V,MAXA,N,NWA,RA,NSCH,DETA,IDETA,1) 00229960 IF(MODEX.EQ.1) RETURN 00229970 FA=DETA 00229980 IFA=IDETA 00229990 IFR=IFA 00230000 IDETR=IDETA 00230010 FR=FA 00230020 DETR=DETA 00230030 IF(A(N,1).GT.ANORM) GO TO 120 00230040 WRITE (6,820) 00230050 MODEX=1 00230060 RETURN 00230070 120 IF (IFPR.EQ.1) 00230080 $ WRITE(6,830) 00230090 CALL QVCPY1(B,W,N) 00230100 RT=0.0E0 00230110 IITE=0 00230120 KK=2 00230130 140 IITE=IITE+1 00230140 CALL QVCOPY(W,V,N) 00230150 CALL BANDET (A,B,V,MAXA,N,NWA,RA,NSCH,DETA,IDETA,KK) 00230160 IF(MODEX.EQ.1) RETURN 00230170 KK=2 00230180 CALL QVDOT(RQT,W,V,N,1,1) 00230190 CALL QVMPY2(W,B,V,N,MMA) 00230200 CALL QVDOT(RQB,W,V,N,1,1) 00230210 RQ=RQT/RQB 00230220 IF (IFPR.EQ.1) 00230230 $ WRITE (6,790) RQ 00230240 IF(IABS(KDYN).EQ.11) BS=DSQRT(DABS(RQB)) 00230250 IF(IABS(KDYN).EQ.11) GO TO 1190 00230260 BS= DSQRT(RQB) 00230270 1190 CONTINUE 00230280 BSI=1.0E0/BS 00230290 TOL= DABS(RQ-RT)/RQ 00230300 IF (TOL.LT.RCBTOL) GO TO 200 00230310 CALL QVMPY1(W,W,BSI,N,1,1,0) 00230320 RT=RQ 00230330 IF (IITE.LT.IITEM) GO TO 140 00230340 200 CALL QVMPY1(V,V,BSI,N,1,1,0) 00230350 TOLI=100*TOL 00230360 RB=RQ*(1.0D0-DMIN1(0.1D0,TOLI)) 00230370 IS=0 00230380 220 CALL BANDET (A,B,V,MAXA,N,NWA,RB,NSCH,DETB,IDETB,1) 00230390 IF(MODEX.EQ.1) RETURN 00230400 IF (IFPR.EQ.1) 00230410 $ WRITE (6,850) RB,NSCH 00230420 FB=DETB 00230430 IFB=IDETB 00230440 IF (NSCH.EQ.0) GO TO 240 00230450 IS=IS+1 00230460 IF (IS.LE.NTF) GO TO 230 00230470 WRITE (6,860) NTF 00230480 MODEX=1 00230490 RETURN 00230500 230 RB=RB/(NSCH+1) 00230510 GO TO 220 00230520 240 IF (IFPR.EQ.1) 00230530 $ WRITE (6,870) 00230540 NITE(JR)=-1 00230550 IF (IFPR.EQ.1) 00230560 $ WRITE (6,880) JR,NITE(JR),RA,DETA,FA,ETA,ISC 00230570 NITE(JR)=0 00230580 IF (IFPR.EQ.1) 00230590 $ WRITE (6,880) JR,NITE(JR),RB,DETB,FB,ETA,ISC 00230600 RX=-0.05E0*RB 00230610 250 IF (NSCH.GE.NROOT) GO TO 660 00230620 IF (RB.GT.COFQ) GO TO 660 00230630 DIF=FB-FA 00230640 SHIFT=0.0 00230650 I=IFA-IFB 00230660 FA=FA*2.0**I 00230670 IFA=IFB 00230680 IF (DIF.NE.0.0E0) GO TO 260 00230690 WRITE (6,890) 00230700 GO TO 660 00230710 260 DEL=FB*(RB-RA)/DIF 00230720 IP=MOD(NITE(JR),3) 00230730 DEL=DEL*2.0**IP 00230740 IF(DEL.GT.RX) DEL=RX 00230750 RC=RB-ETA*DEL 00230760 TOL=RCBTOL*RC 00230770 IF ( DABS(RC-RB).GT.TOL) GO TO 270 00230780 IF (IFPR.EQ.1) 00230790 $ WRITE (6,900) 00230800 ROOT(JR)=RB 00230810 GO TO 330 00230820 270 CALL BANDET (A,B,V,MAXA,N,NWA,RC,NSCH,DETC,IDETC,1) 00230830 IF(MODEX.EQ.1) RETURN 00230840 FC=DETC 00230850 IFC=IDETC 00230860 NITE(JR)=NITE(JR)+1 00230870 IF (JR.EQ.1) GO TO 290 00230880 JJ=JR-1 00230890 DO 280 K=1,JJ 00230900 FC=FC/(RC-ROOT(K)) 00230910 280 CALL RSC(FC,IFC) 00230920 290 IF (IFPR.EQ.1) 00230930 $ WRITE (6,880) JR,NITE(JR),RC,DETC,FC,ETA,ISC 00230940 NES=0 00230950 IF (JR.EQ.1) GO TO 310 00230960 DO 300 I=1,JJ 00230970 300 IF (ROOT(I).LT.RC) NES=NES+1 00230980 310 NOV=NSCH-NES 00230990 IF (NOV.EQ.0) GO TO 320 00231000 IF (IFPR.EQ.1) 00231010 $ WRITE (6,910) NOV 00231020 ROOT(JR)=RC 00231030 RCORIG=RC 00231040 IF (NOV.GT.1) NSK=1 00231050 GO TO 330 00231060 320 RR=RA 00231070 FR=FA 00231080 DETR=DETA 00231090 RA=RB 00231100 FA=FB 00231110 DETA=DETB 00231120 RB=RC 00231130 FB=FC 00231140 DETB=DETC 00231150 IFR=IFA 00231160 IDETR=IDETA 00231170 IFA=IFB 00231180 IDETA=IDETB 00231190 IFB=IFC 00231200 IDETB=IDETC 00231210 TOL=RB*ACTOL 00231220 IF ( DABS(RA-RB).LT.TOL) ETA=ETA*2 00231230 IF (NITE(JR).LE.NITEM) GO TO 250 00231240 WRITE (6,840) JR,NITE(JR) 00231250 GO TO 660 00231260 330 IF (JR.LE.NC) GO TO 340 00231270 WRITE (6,920) 00231280 GO TO 660 00231290 340 NOR=JR-1 00231300 SHIFT=0.0 00231310 IF (NOR.GT.NVM) NOR=NVM 00231320 CALL SECOND (TIM3) 00231330 IF (IFPR.EQ.1) 00231340 $ WRITE (6,930) NOR 00231350 IF (JR.EQ.1) GO TO 360 00231360 RRCC = 1.0D0 R0231361 CALL QVSET(RRCC,V,N) R0231370 KK=2 00231380 IF(JR.EQ.NC) GO TO 360 00231390 I=NITE(JR+1) 00231400 V(I)=-1.0D0 00231410 360 CONTINUE R0231411 CALL QVMPY2(W,B,V,N,MMA) 00231420 IS=0 00231430 RT=ROOT(JR) 00231440 GO TO 430 00231450 380 NITE(JR)=NITE(JR)+1 00231460 CALL QVCOPY(W,V,N) 00231470 CALL BANDET (A,B,V,MAXA,N,NWA,RC,NSCH,DETC,IDETC,KK) 00231480 IF (IS.EQ.1) GO TO 490 00231490 IF(MODEX.EQ.1) RETURN 00231500 ERRT=RQB 00231510 KK=2 00231520 CALL QVDOT(RQT,W,V,N,1,1) 00231530 CALL QVMPY2(W,B,V,N,MMA ) 00231540 CALL QVDOT(RQB,W,V,N,1,1) 00231550 RQ=RQT/RQB 00231560 RT=ROOT(JR)+RQ 00231570 IF (IFPR.EQ.1) 00231580 $ WRITE (6,940) JR,NITE(JR),RT,RQ 00231590 TOL=RT*RQTOL 00231600 IF ( DABS(RT-RTA).GT.TOL) GO TO 430 00231610 IS=1 00231620 GO TO 490 00231630 430 RTA=RT 00231640 IF(IABS(KDYN).EQ.11) BS=DSQRT(DABS(RQB)) 00231650 IF(IABS(KDYN).EQ.11) GO TO 1430 00231660 BS= DSQRT(RQB) 00231670 1430 CONTINUE 00231680 BSI=1.0E0/BS 00231690 CALL QVMPY1(W,W,BSI,N,1,1,0) 00231700 IF (NOR.EQ.0) GO TO 480 00231710 DO 470 K=1,NOR 00231720 CALL QVDOT(AL,VV(1,K),W,N,1,1) 00231730 CALL QMR2(W,W,AL,WW(1,K),N,1,1,1) 00231740 470 CONTINUE 00231750 480 IF(NITE(JR).EQ.0) GO TO 380 00231760 IF(MOD(NITE(JR),NITEM).NE.0) GO TO 482 00231770 TOL=RT*RITOL 00231780 RT=RT+TOL 00231790 CALL BANDET(A,B,V,MAXA,N,NWA,RT,NSCHT,DETT,IDETT,1) 00231800 SHIFT=RT 00231810 IF(IFPR.EQ.1) WRITE(6,483)SHIFT 00231820 483 FORMAT(10X,17HSHIFT APPLIED AT ,E22.14) 00231830 ROOT(JR)=RT 00231840 482 IF(NITE(JR).LE.NITEMM) GO TO 380 00231850 WRITE (6,840) JR,NITE(JR) 00231860 GO TO 660 00231870 490 CONTINUE 00231880 ROOT(JR)=ROOT(JR)+RQ 00231890 ERR= DSQRT(ERRT/RQB) 00231900 ERRVL(JR)=ROOT(JR)-ERR 00231910 ERRVR(JR)=ROOT(JR)+ERR 00231920 IF(IABS(KDYN).EQ.11) BS=DSQRT(DABS(RQB)) 00231930 IF(IABS(KDYN).EQ.11) GO TO 1490 00231940 BS= DSQRT(RQB) 00231950 1490 CONTINUE 00231960 BSI=1.0E0/BS 00231970 CALL QVMPY1(V,V,BSI,N,1,1,0) 00231990 CALL QVMPY1(W,W,BSI,N,1,1,0) 00231980 JJ=JR 00232000 IF (JJ.LE.NVM) GO TO 550 00232010 WRITE (NT) (VV(J,1),J=1,N) 00232020 DO 540 K=1,N 00232030 DO 540 L=2,NVM 00232040 WW(K,L-1)=WW(K,L) 00232050 540 VV(K,L-1)=VV(K,L) 00232060 JJ=NVM 00232070 550 CALL QVCOPY(V,VV(1,JJ),N) 00232090 CALL QVCOPY(W,WW(1,JJ),N) 00232080 CALL SECOND (TIM2) 00232100 TIM3=TIM2-TIM3 00232110 IF (IFPR.EQ.1) 00232120 $ WRITE (6,950) TIM3 00232130 TIM(JR)=TIM2-TIM1 00232140 TIM1=TIM2 00232150 TOL=RTOL*ROOT(JR) 00232160 IF (NOV.GT.0) GO TO 580 00232170 IF ( DABS(ROOT(JR)-RB).GT.TOL) GO TO 620 00232180 IF (RA.GT.0.0E0) GO TO 570 00232190 RA=RB/2.E0 00232200 CALL BANDET (A,B,V,MAXA,N,NWA,RA,NSCH,DETA,IDETA,1) 00232210 IF(MODEX.EQ.1) RETURN 00232220 FA=DETA 00232230 IFA=IDETA 00232240 570 RB=RA 00232250 FB=FA 00232260 DETB=DETA 00232270 RA=RR 00232280 FA=FR 00232290 DETA=DETR 00232300 IFB=IFA 00232310 IDETB=IDETA 00232320 IFA=IFR 00232330 IDETA=IDETR 00232340 GO TO 620 00232350 580 IF (ROOT(JR).GT.RC) NSK=1 00232360 IF (NSK.EQ.1) GO TO 630 00232370 IF ( DABS(RC-ROOT(JR)).LT.TOL) GO TO 600 00232380 IF ( DABS(ROOT(JR)-RB).LT.TOL) GO TO 590 00232390 RA=RB 00232400 FA=FB 00232410 DETA=DETB 00232420 IFA=IFB 00232430 IDETA=IDETB 00232440 590 RB=RC 00232450 FB=FC 00232460 DETB=DETC 00232470 IFB=IFC 00232480 IDETB=IDETC 00232490 GO TO 620 00232500 600 IF ( DABS(ROOT(JR)-RB).GT.TOL) GO TO 620 00232510 IF (RA.GT.0.0E0) GO TO 610 00232520 RA=RB/2.E0 00232530 CALL BANDET (A,B,V,MAXA,N,NWA,RA,NSCH,DETA,IDETA,1) 00232540 IF(MODEX.EQ.1) RETURN 00232550 FA=DETA 00232560 IFA=IDETA 00232570 610 RB=RA 00232580 FB=FA 00232590 DETB=DETA 00232600 RA=RR 00232610 FA=FR 00232620 DETA=DETR 00232630 IFB=IFA 00232640 IDETB=IDETA 00232650 IFA=IFR 00232660 IDETA=IDETR 00232670 620 FA=FA/(RA-ROOT(JR)) 00232680 FB=FB/(RB-ROOT(JR)) 00232690 CALL RSC(FA,IFA) 00232700 CALL RSC(FB,IFB) 00232710 NOV=0 00232720 JR=JR+1 00232730 ETA=2.0E0 00232740 GO TO 240 00232750 630 IF (RA.GT.0.0E0) GO TO 640 00232760 RA=RB/2.E0 00232770 CALL BANDET (A,B,V,MAXA,N,NWA,RA,NSCH,DETA,IDETA,1) 00232780 IF(MODEX.EQ.1) RETURN 00232790 FA=DETA 00232800 IFA=IDETA 00232810 640 IF(SHIFT.LT.ROOT(JR)) SHIFT=0.0 00232820 IF(SHIFT.EQ.0.0) GO TO 645 00232830 RC=SHIFT 00232840 645 IF(DABS(ROOT(JR)-RB).GT.TOL) GO TO 650 00232850 RB=RA 00232860 FB=FA 00232870 DETB=DETA 00232880 RA=RR 00232890 FA=FR 00232900 DETA=DETR 00232910 IFB=IFA 00232920 IDETB=IDETA 00232930 IFA=IFR 00232940 IDETA=IDETR 00232950 650 FA=FA/(RA-ROOT(JR)) 00232960 FB=FB/(RB-ROOT(JR)) 00232970 FR=FR/(RR-ROOT(JR)) 00232980 CALL RSC(FA,IFA) 00232990 CALL RSC(FB,IFB) 00233000 CALL RSC(FR,IFR) 00233010 IF(ROOT(JR).LE.RCORIG) NOV=NOV-1 00233020 IF(NOV.EQ.0) GO TO 655 00233030 IF(SHIFT.NE.0.0) GO TO 655 00233040 IF(JR.EQ.1) GO TO 653 00233050 IF(DABS(ROOT(JR)-ROOT(JR-1)).LT.RITOL*ROOT(JR-1)) GO TO 655 00233060 653 CONTINUE 00233070 IF(DABS(RC-ROOT(JR)).LT.FACT*ROOT(JR)) GO TO 655 00233080 RC=FACT*(RC-ROOT(JR))+ROOT(JR) 00233090 IF(IFPR.EQ.1) WRITE(6,1055)RC 00233100 1055 FORMAT(/10X,4HRC= ,E20.8/) 00233110 CALL BANDET(A,B,V,MAXA,N,NWA,RC,NSCHT,DETT,IDETT,1) 00233120 655 CONTINUE 00233130 JR=JR+1 00233140 NITE(JR)=0 00233150 ROOT(JR)=RC 00233160 IF (NOV.GT.0) GO TO 330 00233170 NSK=0 00233180 ETA=2.0E0 00233190 GO TO 240 00233200 660 IF((JR-1).LT.NROOT) NROOT=JR-1 00233210 IF(NROOT.GT.0) GO TO 670 00233220 WRITE (6,1000) 00233230 MODEX=1 00233240 RETURN 00233250 670 CONTINUE 00233260 IF (IFPR.EQ.0) GO TO 680 00233270 WRITE (6,960) 00233280 WRITE (6,800) (NITE(J),J=1,NROOT) 00233290 WRITE (6,970) 00233300 WRITE (6,810) (TIM(J),J=1,NROOT) 00233310 WRITE (6,980) 00233320 WRITE (6,790) (ERRVL(J),J=1,NROOT) 00233330 WRITE (6,790) (ERRVR(J),J=1,NROOT) 00233340 680 IF (JR-1 .LE.NVM) GO TO 700 00233350 NDIF=JR-1 - NVM 00233360 REWIND NT 00233370 DO 690 L=1,NDIF 00233380 READ (NT) (A(I,L),I=1,N) 00233390 690 CONTINUE 00233400 GO TO 710 00233410 700 NDIF=0 00233420 710 JJR=JR-1 - NDIF 00233430 DO 720 L=1,JJR 00233440 LNDIF=L+NDIF 00233450 720 CALL QVCOPY(VV(1,L),A(1,LNDIF),N) 00233460 IF (JR.EQ.2) GO TO 760 00233470 JR=JR-2 00233480 730 IS=0 00233490 DO 750 I=1,JR 00233500 IF(IABS(KDYN).EQ.11) GO TO 1730 00233510 IF (ROOT(I+1).GE.ROOT(I)) GO TO 750 00233520 GO TO 1740 00233530 1730 IF(DABS(ROOT(I+1)).GE.DABS(ROOT(I))) GO TO 750 00233540 1740 CONTINUE 00233550 IS=IS+1 00233560 RT=ROOT(I+1) 00233570 ROOT(I+1)=ROOT(I) 00233580 ROOT(I)=RT 00233590 DO 740 K=1,N 00233600 RT=A(K,I+1) 00233610 A(K,I+1)=A(K,I) 00233620 740 A(K,I)=RT 00233630 750 CONTINUE 00233640 IF (IS.GT.0) GO TO 730 00233650 760 WRITE (6,990) 00233660 IF(NSCH.LT.NROOT) NROOT=NSCH 00233670 DO 765 J=1,NROOT 00233680 765 ROOT(J)=ROOT(J)+FRSHFT 00233690 WRITE (6,790) (ROOT(J),J=1,NROOT) 00233700 REWIND NT 00233710 IF(IABS(KDYN).EQ.11) GO TO 1770 00233720 DO 770 I=1,NROOT 00233730 IF(ROOT(I).GE.0) GO TO 770 00233740 ROOT(I)=DABS(ROOT(I)) 00233750 WRITE(6,995)I 00233760 770 ROOT(I)= DSQRT(ROOT(I)) 00233770 1770 CONTINUE 00233780 CALL RDWRT(NT,ROOT,NROOT,13,J) 00233790 NWA=N*NROOT 00233800 CALL RDWRT(NT,A,NWA,13,J) 00233810 PI2=8.D0* DATAN(1.0D0) 00233820 DO 780 I=1,NROOT 00233830 780 AT(I)=PI2/ROOT(I) 00233840 RETURN 00233850 790 FORMAT (1H0,6E20.12) 00233860 800 FORMAT (1H0,6I20) 00233870 810 FORMAT (1H0,6F20.2) 00233880 820 FORMAT (44H0***ERROR SOLUTION TERMINATED IN *SECANT *, / 00233890 $ 12X,25HRIGID BODY MODE(S) FOUND., / 1X) 00233900 830 FORMAT (51H INVERSE ITERATION GIVES FOLLOWING APPROXIMATION TO, 00233910 $ 18H LOWEST EIGENVALUE, 1X) 00233920 840 FORMAT (42H0***ERROR PRE-MATURE EXIT FROM *SECANT *, / 12X, 00233930 $ 37HITERATION ABANDONED FOR ROOT NUMBER =, I4 / 12X, 00233940 $ 37HNUMBER OF ITERATIONS PERFORMED =, I4 / 1X) 00233950 850 FORMAT (5H0RB =,E20.12,7H NSCH =,I4) 00233960 860 FORMAT (38H0***ERROR SOLUTION STOP IN *SECANT *, / 12X, 1H(, 00233970 $ I3,48H) FACTORIZATIONS PERFORMED IN AN ATTEMPT TO FIND, 00233980 $ 32H LOWER BOUND ON FIRST EIGENVALUE, / 12X, 00233990 $ 16HCHECK THE MODEL., / 1X) 00234000 870 FORMAT (1X ,4X,4HROOT,4X,4HNITE,18X,2HRC,15X,12HDET (A-RC*B),15X,00234010 $2HFC,13X,3HETA,4X,3HISC) 00234020 880 FORMAT (1H0,4X,I4,4X,I4,8X,3E22.14,F7.2,I6) 00234030 890 FORMAT (42H0THE DEFLATED POLYNOMIAL HAS NO MORE ROOTS ) 00234040 900 FORMAT (29H0(RC-RB) IS SMALLER THAN TOL ) 00234050 910 FORMAT (16H0WE JUMPED OVER ,I4,16H UNKNOWN ROOT(S) ) 00234060 920 FORMAT (42H0***ERROR PRE-MATURE EXIT FROM *SECANTD*, 00234070 $ 34H CAUSED BY EITHER OF THE FOLLOWING, / 12X, 00234080 $ 22H(1) BAD MODEL DATA, OR, / 12X, 00234090 $ 52H(2) ROOT CLUSTER (I.E., NEAR EQUAL OR REPEATED EIGEN, 00234100 $ 36HVALUES) ENCOUNTERED AT CURRENT SHIFT, / 16X, 00234110 $ 25HCAUSING STORAGE OVER-FLOW, 1X) 00234120 930 FORMAT (1H0,34X,4HROOT,18X,2HRQ,18X,4HNOR=,I2) 00234130 940 FORMAT (1H0,4X,I4,4X,I4,8X,2E22.14) 00234140 950 FORMAT (20H0TIME FOR INV ITERN ,F5.2) 00234150 960 FORMAT (42H0NO OF ITERATIONS FOR EACH EIGENVALUE ARE /) 00234160 970 FORMAT (30H0TIME USED FOR EACH EIGENVALUE /) 00234170 980 FORMAT (43H0FOLLOWING ARE ERROR BOUNDS ON EIGENVALUES ) 00234180 990 FORMAT (/// 40H WE SOLVED FOR THE FOLLOWING EIGENVALUES ) 00234190 995 FORMAT(//5X,24H***NOTE: THE ROOT NUMBER,3X,I5,5X,8HIS NEGAT, 00234200 158HIVE. ITS ABSOLUTE VALUE IS TAKEN FOR FURTHER CALCULATIONS) 00234210 1000 FORMAT (38H0***ERROR SOLUTION STOP IN *SECANT *, / 12X, 00234220 $ 23HNO EIGENVALUES COMPUTED, / 1X) 00234230 1010 FORMAT (44H ***ERROR NEG OR ZERO DIAGONAL ELEMENT A(,I4,4H) = ,00234240 X E11.4,21HBEFORE DECOMPOSITION ) 00234250 END 00234260