Liren Large Software Subsidy 9

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

/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 9.ddi / EIGENT2.FOR < prev next >

Wrap

Text File | 1987-06-23 | 88.1 KB | 1,103 lines

SUBROUTINE SSPACE (NEQ,MBAND,NBLOCK,NEQB,NF,NV,NWA,NWV,NWVV,NTB, 00256500 $IFPR,IFSS,NITEM,RTOL,ANORM,COFQ) 00256510 IMPLICIT REAL*8 (A-H,O-Z) 00256520 COMMON /MASS/ LMASS 00256530 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00256540 COMMON/DYN4/KDYN,NRESS,NCRD,NCWT,NRDYN4 R0256550 COMMON /DYN5/FRSHFT,FRINIT,FREND,MODEFR,NOSS R0256560 COMMON /QTSARG/ AT(400),RRQTSA(600) R0256570 COMMON /EXTRA/ MODEX,NREXTR(25) R0256580 COMMON /AAA2/ DL(200),RTOLV(200) R0256581 COMMON A(1) 00256590 N2=1+NWV 00256600 N3=N2+NEQB 00256610 IF(LMASS.EQ.1) N3=N2+NEQB*MBAND 00256620 MMA=1 00256630 IF(LMASS.EQ.1) MMA=MBAND 00256640 CALL SECOND(TIM1) 00256650 CALL INVECT(A(1),A(N2),A(N3),NBLOCK,NEQB,NV,IFPR,MMA) 00256660 IF(MODEX.EQ.1) RETURN 00256670 CALL SECOND(TIM2) 00256680 MI = MBAND + NEQB - 1 00256690 N3=1+NWA 00256700 N2=N3+MI 00256710 IF(IABS(KDYN).EQ.11) GO TO 1110 00256720 CALL DECOMP (A(1),A(N2),A(N3),NEQB,MBAND,NBLOCK,NWA,NTB,NSCH,NEQ,00256730 $ MI) 00256740 1110 CONTINUE 00256750 IF(MODEFR.NE.1) GO TO 70 00256760 WRITE(6,50)NSCH,FRINIT 00256770 50 FORMAT(//10X,9HTHERE ARE,1X,I4,18H FREQUENCIES BELOW,1X,F10.3, 00256780 15H CPS./) 00256790 RETURN 00256800 70 CONTINUE 00256810 IF(MODEX.EQ.1) RETURN 00256820 CALL SECOND (TIM3) 00256830 NN=NEQ - ((NBLOCK-1)*NEQB) 00256840 IF(MODEFR.GT.1) GO TO 100 00256850 IF (A(NN).GT.ANORM) GO TO 100 00256860 IF(IABS(KDYN).EQ.11) GO TO 100 00256870 WRITE (6,280) 00256880 MODEX=1 00256890 RETURN 00256900 100 TIM1=TIM2-TIM1 00256910 TIM2=TIM3-TIM2 00256920 IF (IFPR.EQ.1) 00256930 $ WRITE (6,180) TIM1 00256940 IF (IFPR.EQ.1) 00256950 $ WRITE (6,170) TIM2 00256960 DO 110 I=1,NV 00256970 110 A(I)=0.0E0 00256980 NITE=0 00256990 120 NITE=NITE+1 00257000 WRITE (6,190) NITE 00257010 CALL SECOND (TIM1) 00257020 N1=1+2*NV 00257030 N4=N1+NWA 00257040 N2=N4+MI 00257050 N3=N2+NWV 00257060 CALL REDBAK (A(N1),A(N2),A(N3),A(N4),NEQB,NV,NWA,NWV,NWVV,NTB, 00257070 $ NBLOCK,MI,MBAND) 00257080 N2=1+NV 00257090 N3=N2+NV 00257100 N4=N3+NV*NV 00257110 N5=N4+NV*NV 00257120 N6=N5+NV*NV 00257130 N7=N6+NWV 00257140 N8=N7+NWV R0257150 N9=N8+NV 00257160 CALL SECOND (TIM2) 00257170 CALL EIGSOL ( A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),A(N9)00257180 $,NF,NV,NBLOCK,NEQB,NITE,IFPR,NITEM,RTOL,IFSS,COFQ,MMA) 00257190 IF(MODEX.EQ.1) RETURN 00257200 CALL SECOND (TIM3) 00257210 TIM1=TIM3-TIM1 00257220 TIM2=TIM3-TIM2 00257230 IF (IFPR.EQ.1) 00257240 $ WRITE (6,200) TIM1 00257250 IF (IFPR.EQ.1) 00257260 $ WRITE (6,210) TIM2 00257270 IF (NITE.LT.NITEM) GO TO 120 00257280 WRITE (6,220) 00257290 WRITE (6,230) (A(I),I=1,NF) 00257300 PI2=8.D0* DATAN(1.0D0) 00257310 DO 130 I=1,NF 00257320 AT(I+NF)=A(I+NV) 00257330 IF(IABS(KDYN).EQ.11) GO TO 130 00257340 AT(I)=PI2/ DSQRT(A(I)) 00257350 130 CONTINUE 00257360 IF (IFSS.EQ.1) GO TO 160 00257370 CALL SECOND (TIM1) 00257380 N2=1+NV 00257390 N3=N2+NV 00257400 N4=N3+NWA 00257410 N5=N4+NEQB 00257420 IF(LMASS.EQ.1) N5=N4+NEQB*MBAND 00257430 N6=N5+NV 00257440 N7=N6+NV 00257450 N8=N7+NV 00257460 NWMA=NEQB 00257470 IF(LMASS.EQ.1) NWMA=NWA 00257480 CALL SCHECK (A(1),A(N2),A(N3),A(N4),A(N5),A(N6),A(N7),A(N8),NWA, 00257490 $NEQB,NBLOCK,NF,NV,SHIFT,NEI,IFPR,RTOL,NWMA) 00257500 IF(MODEX.EQ.1) RETURN 00257510 WRITE (6,240) SHIFT 00257520 N3=1+NWA 00257530 N2=N3+MI 00257540 CALL DECOMP (A(1),A(N2),A(N3),NEQB,MBAND,NBLOCK,NWA,NTB,NSCH,NEQ,00257550 $ MI) 00257560 IF(MODEX.EQ.1) RETURN 00257570 IF (NSCH.EQ.NEI) GO TO 140 00257580 NSCH=NSCH-NEI 00257590 WRITE (6,250) NSCH 00257600 GO TO 150 00257610 140 WRITE (6,260) NSCH 00257620 150 CALL SECOND (TIM2) 00257630 TIM2=TIM2-TIM1 00257640 WRITE (6,270) TIM2 00257650 160 RETURN 00257660 170 FORMAT (34H0TIME FOR STIFFNESS FACTORIZATION ,F6.2) 00257670 180 FORMAT (42H0TIME FOR GENERATION OF INITIAL TR-VECTORS ,F6.2) 00257680 190 FORMAT(31H0ITERATION NUMBER (*SSPACEB*) =,I4) 00257690 200 FORMAT (24H0TIME USED IN ITERN STEP ,F6.2) 00257700 210 FORMAT (25H0TIME FOR EIGENVALUE SOLN ,F6.2) 00257710 220 FORMAT (/// 40H WE SOLVED FOR THE FOLLOWING EIGENVALUES ) 00257720 230 FORMAT (1H0,6E22.14) 00257730 240 FORMAT (1X ,22HCHECK APPLIED AT SHIFT ,E22.14) 00257740 250 FORMAT (10H0THERE ARE ,I4,21H EIGENVALUES MISSING ) 00257750 260 FORMAT (20H0WE FOUND THE LOWEST ,I4,12H EIGENVALUES ) 00257760 270 FORMAT (30H0TIME FOR STURM SEQUENCE CHECK ,F6.2) 00257770 280 FORMAT (38H0***ERROR SOLUTION STOP IN *SSPACEB*, / 12X, 00257780 $ 25HRIGID BODY MODE(S) FOUND., / 1X) 00257790 END 00257800 SUBROUTINE INVECT (VA,XM,IEQ,NBLOCK,NEQB,NV,IFPR,MMA) 00120920 IMPLICIT REAL*8 (A-H,O-Z) 00120930 COMMON/DYN3/ NEIG,NAD,ANORM,NVV,NFO 00120940 COMMON/DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 R0120950 COMMON /EXTRA/ MODEX,NREXTR(25) R0120960 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00120970 DIMENSION VA(NEQB,NV),XM(NEQB,MMA),IEQ(1) 00120980 NV1=NV-1-NFO 00120990 IF(NV1.LT.1) GO TO 190 00121000 KK=1 00121010 IND=0 00121020 100 NBV=KK*((NV1-1)/NBLOCK+1) 00121030 IF (NBV.GT.NEQB) NBV=NEQB 00121040 IF (NBV.EQ.NEQB) IND=1 00121050 NBVN=0 00121060 ICOUNT=0 00121070 LL=0 00121080 REWIND NMASS 00121090 110 READ (NMASS) XM,(VA(I,1),I=1,NEQB) 00121100 ICOUNT=ICOUNT+1 00121110 DO 120 I=1,NEQB 00121120 IF(VA(I,1).EQ.0.0E0) GO TO 120 00121130 VA(I,1)=XM(I,1)/VA(I,1) 00121140 IF(IABS(KDYN).EQ.11) VA(I,1)=DABS(VA(I,1)) 00121150 120 CONTINUE 00121160 NNV=NEQB/NBV 00121170 DO 160 L=1,NBV 00121180 RT=0.0E0 00121190 NN=L*NNV 00121200 DO 130 I=1,NN 00121210 IF(VA(I,1).LT.RT) GO TO 130 00121220 RT=VA(I,1) 00121230 IJ=I 00121240 130 CONTINUE 00121250 DO 140 I=NN,NEQB 00121260 IF(VA(I,1).LE.RT) GO TO 140 00121270 RT=VA(I,1) 00121280 IJ=I 00121290 140 CONTINUE 00121300 IF(VA(IJ,1).NE.0.0E0) GO TO 150 00121310 NBVN=NBVN+1 00121320 GO TO 160 00121330 150 LL=LL+1 00121340 IEQ(LL)=(ICOUNT-1)*NEQB+IJ 00121350 IF (LL.GE.NV1) GO TO 190 00121360 VA(IJ,1)=0.0E0 00121370 160 CONTINUE 00121380 IF (IND.EQ.1) GO TO 170 00121390 IF ((NBVN.EQ.0).OR.(ICOUNT.EQ.NBLOCK)) GO TO 170 00121400 NBV=KK*((NV1-LL-1)/(NBLOCK-ICOUNT)+1) 00121410 IF (NBV.GT.NEQB) NBV=NEQB 00121420 NBVN=0 00121430 170 IF (ICOUNT.LT.NBLOCK) GO TO 110 00121440 IF (IND.EQ.1) GO TO 180 00121450 KK=2*KK 00121460 GO TO 100 00121470 180 WRITE (6,260) 00121480 MODEX=1 00121490 RETURN 00121500 190 REWIND NMASS 00121510 REWIND NR 00121520 REWIND NT 00121530 NSH1=NFO+1 00121540 NSH2=NFO+2 00121550 DO 250 L=1,NBLOCK 00121560 9997 FORMAT(5X,16HBLOCK NUMBER, L=,I5) 00121570 READ (NMASS) XM 00121580 9998 FORMAT(5X,26HMASS MATRIX EQUATION NO. =,I5,/,(5X,10E12.5)) 00121590 IF(NV1.LT.1) GO TO 245 00121600 IF(NFO.LE.0) GO TO 200 00121610 READ(NT) VA 00121620 200 DO 210 I=1,NEQB 00121630 VA(I,NSH1)=XM(I,1) 00121640 DO 210 J=NSH2,NV 00121650 210 VA(I,J)=0.0E0 00121660 DO 240 K=1,NV1 00121670 II=IEQ(K) 00121680 NLE=(L-1)*NEQB 00121690 NRI=L*NEQB 00121700 IF (II-NLE) 240,240,220 00121710 220 IF (NRI-II) 240,230,230 00121720 230 II=II-NLE 00121730 VA(II,K+NSH1)=1.E0 00121740 240 CONTINUE 00121750 GO TO 247 00121760 245 DO 246 I=1,NEQB 00121770 246 VA(I,1)=XM(I,1) 00121780 247 CONTINUE 00121790 WRITE (NR) VA 00121800 9999 FORMAT(5X,23HVA ARRAY EQUATION NO. =,I5,/,5X,(10E12.5)) 00121810 250 CONTINUE 00121820 IF(NV1.LT.1) RETURN 00121830 IF (IFPR.EQ.1) 00121840 $ WRITE (6,270) 00121850 IF (IFPR.EQ.1) 00121860 $ WRITE (6,280) (IEQ(I),I=1,NV1) 00121870 RETURN 00121880 260 FORMAT (37H0***ERROR SOLUTION STOP IN *INVECT*, / 12X, 00121890 $ 42HINSUFFICIENT NUMBER OF FINITE EIGENVALUES., / 1X) 00121900 270 FORMAT (20H0PRINT OF VECTOR IEQ ) 00121910 280 FORMAT (1H0,20I6) 00121920 END 00121930 SUBROUTINE DECOMP (A,B,MAXA,NEQB,MA,NBLOCK,NWA,NTB,NSCH,NEQ,MI) 00052930 IMPLICIT REAL*8 (A-H,O-Z) 00052940 REAL*8 MAXA 00052950 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00052960 COMMON /EXTRA/ MODEX,NREXTR(25) R0052970 COMMON /SQZ/ ISQZ,NRSQZ(5) R0052980 DIMENSION A(NWA),B(NWA),MAXA(MI) 00052990 DIMENSION ICOO(10),IFORM(4) R0053000 DATA ICOO /3H001,3H013,3H025,3H037,3H049,3H061,3H073,3H085,3H097, 00053010 $ 3H109/ 00053020 DATA IFORM(1),IFORM(3),IFORM(4) /4H(1H+,4HX,F7,4H.2) / R0053030 MA2=MA - 2 00053040 IF(MA2.EQ.0) MA2=1 00053050 INC=NEQB - 1 00053060 IF(INC.EQ.0)INC=1 00053070 N1=NL 00053080 N2=NT 00053090 IF(N1.EQ.62) N1=22 R0053100 IF(N2.EQ.62) N2=22 R0053110 NWANM=NWA+MI 00053120 WRITE (6,2002) NSTIF,NRED,N1,N2,NWA 2002 FORMAT (5X,'*** NSTIF NRED N1 N2 NWA ***',5I5/) CALL RDWRT(NSTIF,A,1,6,I) 00053130 CALL RDWRT(NRED ,A,1,6,I) 00053140 CALL RDWRT(N1 ,A,1,6,I) 00053150 CALL RDWRT(N2 ,A,1,6,I) 00053160 NSCH=0 00053170 WRITE(6,90) 00053180 90 FORMAT(1X ,10X,48HTHE LAST NUMBER PRINTED IS THE PERCENT OF THE FO00053190 $ ,40HRWARD REDUCTION THAT HAS BEEN COMPLETED.//) 00053200 ICO=1 00053210 DO 420 NJ=1,NBLOCK 00053220 IF (NJ.NE.1) GO TO 100 00053230 CC CALL EXPAND(A,NWA,NSTIF) 00053240 READ (NSTIF) A GO TO 110 00053250 100 IF (NTB.EQ.1) GO TO 110 00053260 CALL RDWRT(N1 ,A,1,6,I) 00053270 CALL RDWRT(N2 ,A,1,6,I) 00053280 CALL EXPAND(A,NWA,N1) 00053290 CC READ (NSTIF) A 110 KU=1 00053300 KM=MIN0(MA,NEQB) 00053310 MAXA(1)=1 00053320 DO 170 N=2,MI 00053330 IF (N-MA) 120,120,130 00053340 120 KU=KU + NEQB 00053350 KK=KU 00053360 MM=MIN0(N,KM) 00053370 GO TO 150 00053380 130 KU=KU + 1 00053390 KK=KU 00053400 IF (N-NEQB) 150,150,140 00053410 140 MM=MM - 1 00053420 150 DO 160 K=1,MM 00053430 IF (A(KK)) 170,160,170 00053440 160 KK=KK - INC 00053450 170 MAXA(N)=KK 00053460 IF (A(1)) 190,180,200 00053470 180 KK=(NJ-1)*NEQB + 1 00053480 IF (KK.GT.NEQ) GO TO 390 00053490 WRITE (6,430) KK 00053500 MODEX=1 00053510 RETURN 00053520 190 NSCH=NSCH + 1 00053530 200 DO 280 N=2,NEQB 00053540 NH=MAXA(N) 00053550 IF (NH-N) 280,280,210 00053560 210 KL=N + INC 00053570 KU=NH 00053580 K=N 00053590 D=0.E0 00053600 DO 220 KK=KL,KU,INC 00053610 K=K - 1 00053620 C=A(KK)/A(K) 00053630 D=D + C*A(KK) 00053640 220 A(KK)=C 00053650 A(N)=A(N) - D 00053660 IF (A(N)) 240,230,250 00053670 230 KK=(NJ-1)*NEQB + N 00053680 IF (KK.GT.NEQ) GO TO 390 00053690 WRITE (6,430) KK 00053700 A(N)=-1.0E-10-(N*1.0E-13) 00053710 240 NSCH=NSCH + 1 00053720 250 IC=NEQB 00053730 DO 270 J=1,MA2 00053740 MJ=MAXA(N+J) - IC 00053750 IF (MJ-N) 270,270,260 00053760 260 KU=MIN0(MJ,NH) 00053770 KN=N + IC 00053780 C=0.E0 00053790 CONST=C 00053800 CALL QVDOT(C,A(KL),A(KL+IC), (KU-KL)/INC+1,INC,INC) 00053810 C=CONST-C 00053820 A(KN)=A(KN)+C 00053830 270 IC=IC + NEQB 00053840 280 CONTINUE 00053850 IF(NJ.EQ.NBLOCK) CALL SQEEZE(A,NWANM,NRED,ISQZ) 00053860 IF(NJ.EQ.NBLOCK) GO TO 400 00053870 290 DO 380 NK=1,NTB 00053880 IF ((NK+NJ).GT.NBLOCK) GO TO 380 00053890 NI=N1 00053900 IF ((NJ.EQ.1).OR.(NK.EQ.NTB)) NI=NSTIF 00053910 CALL EXPAND(B,NWA,NI) 00053920 ML=NK*NEQB + 1 00053930 MR=MIN0((NK+1)*NEQB,MI) 00053940 MD=MI - ML 00053950 KL=NEQB + (NK-1)*NEQB*NEQB 00053960 N=1 00053970 DO 360 M=ML,MR 00053980 NH=MAXA(M) 00053990 KL=KL + NEQB 00054000 IF (NH-KL) 350,300,300 00054010 300 KU=NH 00054020 K=NEQB 00054030 D=0.E0 00054040 DO 310 KK=KL,KU,INC 00054050 C=A(KK)/A(K) 00054060 D=D + C*A(KK) 00054070 A(KK)=C 00054080 310 K=K - 1 00054090 B(N)=B(N) - D 00054100 IF (MD) 360,360,320 00054110 320 IC=NEQB 00054120 DO 340 J=1,MD 00054130 MJ=MAXA(M+J) - IC 00054140 IF (MJ-KL) 340,330,330 00054150 330 KU=MIN0(MJ,NH) 00054160 KN=N + IC 00054170 C=0.E0 00054180 CONST=C 00054190 CALL QVDOT(C,A(KL),A(KL+IC), (KU-KL)/INC+1,INC,INC) 00054200 C=CONST-C 00054210 B(KN)=B(KN)+C 00054220 340 IC=IC + NEQB 00054230 350 MD=MD - 1 00054240 360 N=N + 1 00054250 IF (NTB.NE.1) GO TO 370 00054260 CALL SQEEZE(A,NWANM,NRED,ISQZ) 00054270 CALL MEMOVE(B(1),A(1),NWA) 00054280 GO TO 400 00054290 370 CALL SQEEZE(B,NWA,N2,ISQZ) 00054300 380 CONTINUE 00054310 M=N1 00054320 N1=N2 00054330 N2=M 00054340 390 CALL SQEEZE(A,NWANM,NRED,ISQZ) 00054350 400 CONTINUE 00054360 PER=NJ*100.0/NBLOCK 00054370 IFORM(2)=ICOO(ICO) 00054380 WRITE(6,2003) PER R0054390 2003 FORMAT (5X,F10.2/) R0054391 ICO=ICO+1 00054400 IF(ICO.LT.11) GO TO 420 00054410 CC WRITE(6,410) 00054420 CC410 FORMAT(1H ) 00054430 ICO=1 00054440 420 CONTINUE 00054450 430 FORMAT (37H0***ERROR SOLUTION STOP IN *DECOMP*, / 12X, 00054460 $ 37HZERO PIVOT FOUND DURING FACTORIZATION, / 12X, 00054470 $ 17HEQUATION NUMBER =, I5 / 1X 00054480 $ ,11X,47HTHE PIVOT WILL BE CHANGED TO A SMALL NEG. VALUE/ 00054490 $ 12X,33HTHE FREQUENCIES MAY BE IN ERROR |, / 1X) 00054500 WRITE(6,440) 00054510 440 FORMAT(////20X,37(1H*)/20X,37HFORWARD REDUCTION HAS BEEN COMPLETED00054520 $./20X,37(1H*)) 00054530 RETURN 00054540 END 00054550 SUBROUTINE REDBAK (A,VA,VV,MAXA,NEQB,NV,NWA,NWV,NWVV,NTB,NBLOCK, 00201210 $MI,MA) 00201220 IMPLICIT REAL*8 (A-H,O-Z) 00201230 REAL*8 MAXA 00201240 COMMON /SQZ/ ISQZ,NRSQZ(5) R0201250 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00201260 DIMENSION A(NWA),VA(NWV),VV(NWVV),MAXA(MI) 00201270 NWANM=NWA+MI 00201280 INC=NEQB - 1 00201290 IF(INC.EQ.0) INC=1 00201300 NEB=NTB*NEQB 00201310 NEBT=NEB+NEQB 00201320 CALL RDWRT(NRED ,A,1,6,I) 00201330 REWIND NR 00201340 REWIND NL 00201350 REWIND NT 00201360 CALL EXPAND(A,NWANM,NRED) 00201370 ISV=NTB+1 00201380 IF (NBLOCK.EQ.1) ISV=1 00201390 LL=0 00201400 DO 120 L=1,ISV 00201410 READ (NR) VA 00201420 K=0 00201430 KK=LL 00201440 DO 110 J=1,NV 00201450 DO 100 I=1,NEQB 00201460 K=K+1 00201470 KK=KK+1 00201480 100 VV(KK)=VA(K) 00201490 110 KK=KK+NEB 00201500 120 LL=LL+NEQB 00201510 ISA=1 00201520 130 DO 160 N=2,NEQB 00201530 KL=N + INC 00201540 KU=MAXA(N) 00201550 IF (KU-KL) 160,140,140 00201560 140 K=N 00201570 DO 150 L=1,NV 00201580 CONST=VV(K) 00201590 CALL QVDOT(VV(K ),A(KL),VV(K-1), (KU-KL)/INC+1,INC,-1) 00201600 VV(K )=CONST-VV(K ) 00201610 150 K=K + NEBT 00201620 160 CONTINUE 00201630 170 KL=NEQB 00201640 ML=NEQB + 1 00201650 DO 200 N=ML,MI 00201660 KL=KL + NEQB 00201670 KU=MAXA(N) 00201680 IF (KU-KL) 200,180,180 00201690 180 K=NEQB 00201700 KN=N 00201710 DO 190 L=1,NV 00201720 CONST=VV(KN) 00201730 CALL QVDOT(VV(KN ),A(KL),VV(K) ,(KU-KL)/INC+1,INC,-1) 00201740 VV(KN )=CONST-VV(KN ) 00201750 K=K + NEBT 00201760 190 KN=KN + NEBT 00201770 200 CONTINUE 00201780 DO 230 I=1,NEQB 00201790 C=A(I) 00201800 IF (C) 210,230,210 00201810 210 KK=I 00201820 DO 220 L=1,NV 00201830 VV(KK)=VV(KK)/C 00201840 220 KK=KK+NEBT 00201850 230 CONTINUE 00201860 IF (ISA.EQ.NBLOCK) GO TO 300 00201870 CALL EXPAND(A,NWANM,NRED) 00201880 ISA=ISA+1 00201890 K=0 00201900 KK=0 00201910 DO 250 J=1,NV 00201920 DO 240 I=1,NEQB 00201930 K=K+1 00201940 KK=KK+1 00201950 240 VA(K)=VV(KK) 00201960 250 KK=KK+NEB 00201970 WRITE (NT) VA 00201980 K=1 00201990 DO 270 J=1,NV 00202000 DO 260 I=1,NEB 00202010 VV(K)=VV(K+NEQB) 00202020 260 K=K+1 00202030 270 K=K+NEQB 00202040 IF (ISV.EQ.NBLOCK) GO TO 130 00202050 READ (NR) VA 00202060 ISV=ISV+1 00202070 KK=NEB 00202080 K=0 00202090 DO 290 J=1,NV 00202100 DO 280 I=1,NEQB 00202110 K=K+1 00202120 KK=KK+1 00202130 280 VV(KK)=VA(K) 00202140 290 KK=KK+NEB 00202150 GO TO 130 00202160 300 CALL RDWRT(NRED ,A,1,2,I) 00202170 ISA=1 00202180 310 ML=NEQB+1 00202190 KL=NEQB 00202200 DO 340 M=ML,MI 00202210 KL=KL+NEQB 00202220 KU=MAXA(M) 00202230 IF (KU-KL) 340,320,320 00202240 320 K=NEQB 00202250 KM=M 00202260 DO 330 L=1,NV 00202270 CALL QMR2(VV(K ),VV(K ),VV(KM),A(KL),(KU-KL)/INC+1,-1,-1,INC) 00202280 KM=KM + NEBT 00202290 330 K=K + NEBT 00202300 340 CONTINUE 00202310 N=NEQB 00202320 DO 370 LJ=2,NEQB 00202330 KL=N + INC 00202340 KU=MAXA(N) 00202350 IF (KU-KL) 370,350,350 00202360 350 K=N 00202370 DO 360 L=1,NV 00202380 CALL QMR2(VV(K-1 ),VV(K-1 ),VV(K ),A(KL),(KU-KL)/INC+1,-1,-1,INC) 00202390 360 K=K + NEBT 00202400 370 N=N - 1 00202410 380 KK=0 00202420 K=0 00202430 DO 400 J=1,NV 00202440 DO 390 I=1,NEQB 00202450 K=K+1 00202460 KK=KK+1 00202470 390 VA(K)=VV(KK) 00202480 400 KK=KK+NEB 00202490 WRITE (NL) VA 00202500 IF (ISA.EQ.NBLOCK) GO TO 450 00202510 CALL RDWRT(NRED ,A,1,2,I) 00202520 CALL EXPAND(A,NWANM,NRED) 00202530 CALL RDWRT(NRED ,A,1,2,I) 00202540 ISA=ISA+1 00202550 BACKSPACE NT 00202560 READ (NT) VA 00202570 BACKSPACE NT 00202580 LNTRC=NWV*4 00202590 K=NEBT 00202600 DO 420 J=1,NV 00202610 DO 410 I=1,NEB 00202620 VV(K)=VV(K-NEQB) 00202630 410 K=K-1 00202640 420 K=K+NEBT+NEB 00202650 K=0 00202660 KK=0 00202670 DO 440 J=1,NV 00202680 DO 430 I=1,NEQB 00202690 K=K+1 00202700 KK=KK+1 00202710 430 VV(KK)=VA(K) 00202720 440 KK=KK+NEB 00202730 GO TO 310 00202740 450 RETURN 00202750 END 00202760 SUBROUTINE EIGSOL ( AR,BR,VEC,VL,VR,D,XM,NF,NV,NBLOCK, R0069250 $NEQB,NITE,IFPR,NITEM,RTOL,IFSS,COFQ,MMA) 00069260 IMPLICIT REAL*8 (A-H,O-Z) 00069270 COMMON /EXTRA/ MODEX,NREXTR(25) R0069280 COMMON/MASS/LMASS 00069290 COMMON/DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 R0069300 COMMON /DYN5/FRSHFT,FRINIT,FREND,MODEFR,NOSS R0069310 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00069320 COMMON /AAA2/ DL(200),RTOLV(200) R0069321 DIMENSION AR(NV,NV),BR(NV,NV),VEC(NV,NV),VL(NEQB,NV),VR(NEQB,NV) 00069330 DIMENSION D(NV) ,XM(NEQB,MMA) R0069340 LNLRC=4*NEQB*NV 00069350 TOLJ=1.0E-12 00069360 REWIND NMASS 00069370 N18=18 00069380 FI=FRINIT-FRSHFT 00069390 FE=COFQ-FRSHFT 00069400 REWIND NT 00069410 REWIND NR 00069420 DO 100 I=1,NV 00069430 DO 100 J=I,NV 00069440 AR(I,J)=0.0E0 00069450 100 BR(I,J)=0.0E0 00069460 IF(LMASS.EQ.1) GO TO 1100 00069470 DO 160 N=1,NBLOCK 00069480 BACKSPACE NL 00069490 READ (NL) VL 00069500 BACKSPACE NL 00069510 READ (NR) VR 00069520 READ (NMASS) XM 00069530 DO 120 I=1,NV 00069540 DO 120 J=I,NV 00069550 CALL QVDOT(ART,VL(1,I),VR(1,J),NEQB,1,1) 00069560 120 AR(I,J)=AR(I,J)+ART 00069570 DO 130 I=1,NEQB 00069580 XMM=XM(I,1) 00069590 DO 130 J=1,NV 00069600 130 VR(I,J)=VL(I,J)*XMM 00069610 WRITE (NT) VR 00069620 DO 150 I=1,NV 00069630 DO 150 J=I,NV 00069640 CALL QVDOT(BRT,VL(1,I),VR(1,J),NEQB,1,1) 00069650 150 BR(I,J)=BR(I,J)+BRT 00069660 160 CONTINUE 00069670 GO TO 1170 00069680 1100 CONTINUE 00069690 CALL GDYNIN(VL,NV,NBLOCK,NEQB,N18,NL) R0069700 REWIND N18 00069710 DO 1130 N=1,NBLOCK 00069720 READ (N18) VL R0069730 READ (NR) VR R0069740 DO 1120 I=1,NV 00069750 DO 1120 J=I,NV 00069760 CALL QVDOT(ART,VL(1,I),VR(1,J),NEQB,1,1) 00069770 1120 AR(I,J)=AR(I,J)+ART 00069780 1130 CONTINUE 00069790 CALL QMBAND(XM,VL,VR(1,1),VR(1,1),VR(1,1),NEQB,MMA,NV,NBLOCK, R0069800 1NWMA,NEQ,NMASS,N18,23,41,NT) 00069810 REWIND N18 00069820 REWIND NT 00069830 DO 1160 N=1,NBLOCK 00069840 READ (NT) VR R0069850 READ (N18) VL R0069860 DO 1150 I=1,NV 00069870 DO 1150 J=I,NV 00069880 CALL QVDOT(BRT,VL(1,I),VR(1,J),NEQB,1,1) 00069890 1150 BR(I,J)=BR(I,J)+BRT 00069900 1160 CONTINUE 00069910 1170 CONTINUE 00069920 DO 170 I=1,NV 00069930 DO 170 J=1,I 00069940 AR(I,J)=AR(J,I) 00069950 170 BR(I,J)=BR(J,I) 00069960 IF (IFPR.EQ.0) GO TO 200 00069970 WRITE (6,480) 00069980 DO 180 I=1,NV 00069990 180 WRITE (6,460) (AR(I,J),J=1,NV) 00070000 WRITE (6,490) 00070010 DO 190 I=1,NV 00070020 190 WRITE (6,460) (BR(I,J),J=1,NV) 00070030 CALL SECOND (T1) 00070040 200 CALL JACOBI (AR,BR,VEC,D,VL,NV,TOLJ,IFPR) R0070050 IF(MODEX.EQ.1) RETURN 00070060 DO 240 J=1,NV 00070070 IF (BR(J,J).GT.0.E0) GO TO 230 00070080 IF(IABS(KDYN).NE.11) GO TO 215 00070090 XMM=DABS(BR(J,J)) 00070100 XMM=DSQRT(XMM) 00070110 GO TO 235 00070120 215 CONTINUE 00070130 WRITE (6,540) 00070140 WRITE (6,480) 00070150 DO 210 L1=1,NV 00070160 210 WRITE (6,460) (AR(L1,L2),L2=1,NV) 00070170 WRITE (6,490) 00070180 DO 220 L1=1,NV 00070190 220 WRITE (6,460) (BR(L1,L2),L2=1,NV) 00070200 MODEX=1 00070210 RETURN 00070220 230 XMM= DSQRT(BR(J,J)) 00070230 235 CONTINUE 00070240 DO 240 K=1,NV 00070250 240 VEC(K,J)=VEC(K,J)/XMM 00070260 IF (IFPR.EQ.0) GO TO 270 00070270 CALL SECOND (T2) 00070280 T3=T2 - T1 00070290 WRITE (6,550) T3 00070300 WRITE (6,500) 00070310 WRITE (6,480) 00070320 DO 250 I=1,NV 00070330 250 WRITE (6,460) (AR(I,J),J=1,NV) 00070340 WRITE (6,490) 00070350 DO 260 I=1,NV 00070360 260 WRITE (6,460) (BR(I,J),J=1,NV) 00070370 270 NV1=NV-1 00070380 IF(NV1.EQ.0) GO TO 1300 00070390 280 IS=0 00070400 DO 300 I=1,NV1 00070410 IF(DABS(D(I+1)).GE.DABS(D(I)))GO TO 300 00070420 IS=IS+1 00070430 BT=BR(I+1,I+1) 00070440 DT=D(I+1) 00070450 BR(I+1,I+1)=BR(I,I) 00070460 D(I+1)=D(I) 00070470 BR(I,I)=BT 00070480 D(I)=DT 00070490 DO 290 K=1,NV 00070500 TEMP=VEC(K,I+1) 00070510 VEC(K,I+1)=VEC(K,I) 00070520 290 VEC(K,I)=TEMP 00070530 300 CONTINUE 00070540 IF (IS.GT.0) GO TO 280 00070550 1300 CONTINUE 00070560 NFI=1 00070570 NFF=NF 00070580 IF(FRINIT.LE.0.0E0) GO TO 304 00070590 IS=0 00070600 NFHOLD=0 00070610 DO 301 I=1,NV 00070620 IF(D(I).LT.FI) IS=IS+1 00070630 IF(D(I).LE.FE) NFHOLD=NFHOLD+1 00070640 301 CONTINUE 00070650 IF(IS.EQ.0.OR.NFHOLD.EQ.0) GO TO 304 00070660 NFI=IS+1 00070670 NFF=NFHOLD 00070680 304 CONTINUE 00070690 DO 320 I=1,NV 00070700 IF (D(I).GT.0.E0) GO TO 310 00070710 IF(MODEFR.GT.1) GO TO 310 00070720 IF(IABS(KDYN).EQ.11) GO TO 310 00070730 WRITE (6,560) 00070740 MODEX=1 00070750 RETURN 00070760 310 DIF= DABS(DL(I)-D(I)) 00070770 320 RTOLV(I)= DABS(DIF/D(I)) 00070780 IF(IFPR.EQ.0) GO TO 330 00070790 WRITE (6,510) 00070800 WRITE (6,460) (RTOLV(I),I=1,NV) 00070810 330 CONTINUE 00070820 NFHOLD=NF 00070830 NEND=0 00070840 IF(MODEFR.GT.1) GO TO 350 00070850 DO 340 L=1,NF 00070860 IF (D(L).LT.COFQ) GO TO 340 00070870 IF (RTOLV(L).GT.RTOL) GO TO 350 00070880 NFHOLD=L 00070890 GO TO 350 00070900 340 CONTINUE 00070910 350 NF=NFHOLD 00070920 DO 360 I=NFI,NFF 00070930 IF (RTOLV(I).GT.RTOL) GO TO 370 00070940 360 CONTINUE 00070950 IS=NFF-NFI+1 00070960 IF(MODEFR.GT.1.AND.NITE.LT.NITEM.AND.IS.NE.NF) GO TO 370 00070970 WRITE (6,520) NF,RTOL 00070980 NITE=NITEM 00070990 GO TO 380 00071000 370 IF(NITE.EQ.NITEM-2) IFPR=1 00071010 IF(NITE.LT.NITEM ) GO TO 400 00071020 WRITE (6,530) 00071030 IFSS=1 00071040 380 DO 390 I=1,NV 00071050 D(I)=D(I)+FRSHFT 00071060 DL(I)=D(I) 00071070 IF(IABS(KDYN).EQ.11) GO TO 390 00071080 IF(D(I).LT.0.)WRITE(6,570)I,D(I) 00071090 IF(D(I).LT.0.)D(I)=DABS(D(I)) 00071100 D(I)= DSQRT(D(I)) 00071110 390 CONTINUE 00071120 IF(MODEFR.LE.1) GO TO 393 00071130 IF(NFF-NFI+1.NE.NF) WRITE(6,391) 00071140 391 FORMAT(//10X,47H--WARNING -- NO. OF EIGENVALUES MAY BE IN ERROR/) 00071150 NF=NFF-NFI+1 00071160 IF(NFI.EQ.1) GO TO 393 00071170 NEND=1 00071180 IS=NFI-1 00071190 DO 392 I=1,NF 00071200 M=IS+I 00071210 DT=D(M) 00071220 D(M)=D(I) 00071230 BT=RTOLV(M) 00071240 RTOLV(M)=RTOLV(I) 00071250 RTOLV(I)=BT 00071260 BT=DL(M) 00071270 DL(M)=DL(I) 00071280 DL(I)=BT 00071290 392 D(I)=DT 00071300 393 CONTINUE 00071310 M=NT 00071320 NT=NL 00071330 NL=M 00071340 M=NR 00071350 NR=NL 00071360 NL=M 00071370 REWIND NR 00071380 WRITE (NR) (D(I),I=1,NF) 00071390 GO TO 420 00071400 400 DO 410 I=1,NV 00071410 410 DL(I)=D(I) 00071420 REWIND NR 00071430 420 REWIND NT 00071440 DO 450 N=1,NBLOCK 00071450 READ (NT) VR R0071460 DO 440 J=1,NV 00071470 DO 440 I=1,NEQB 00071480 TEMP=0.0E0 00071490 DO 430 K=1,NV 00071500 430 TEMP=TEMP+VR(I,K)*VEC(K,J) 00071510 440 VL(I,J)=TEMP 00071520 IF(NEND.EQ.0) GO TO 450 00071530 DO 441 K=1,NF 00071540 M=IS+K 00071550 DO 441 I=1,NEQB 00071560 TEMP=VL(I,M) 00071570 VL(I,M)=VL(I,K) 00071580 441 VL(I,K)=TEMP 00071590 450 WRITE (NR) VL R0071600 RETURN 00071610 460 FORMAT (1H ,12E11.4) 00071620 470 FORMAT (1H0,6E20.14) 00071630 480 FORMAT (10H0MATRIX AR ) 00071640 490 FORMAT (10H0MATRIX BR ) 00071650 500 FORMAT (40H0AR AND BR AFTER JACOBI DIAGONALIZATION ) 00071660 510 FORMAT (52H0RELATIVE TOLERANCE REACHED ON EIGENVALUES IS NOW ) 00071670 520 FORMAT (33H0CONVERGENCE ACHIEVED IN *EIGSOL*, / 00071680 $ 27H NUMBER OF EIGENVALUES = , I3 / 00071690 $ 27H RELATIVE TOLERANCE = , E12.4 // 1X) 00071700 530 FORMAT (52H0WE ACCEPT THE CURRENT EIGENVALUE APPROXIMATIONS )00071710 540 FORMAT (37H0***ERROR SOLUTION STOP IN *EIGSOL*, / 12X, 00071720 $ 39HNEGATIVE DIAGONAL ELEMENT IN MATRIX BR., // 1X) 00071730 550 FORMAT (28H0TIME FOR JACOBI ITERATION =,F10.4) 00071740 560 FORMAT (37H0***ERROR SOLUTION STOP IN *EIGSOL*, / 12X, 00071750 $ 44HINADMISSIBLE NEGATIVE EIGENVALUE CALCULATED., / 1X) 00071760 570 FORMAT(19H ***WARNING*** MODE,I5,15H HAS A NEGATIVE, 00071770 & 13H EIGENVALUE =,E15.5) 00071780 END 00071790 SUBROUTINE JACOBI (A,B,X,EIGV,D,N,RTOL,IFPR) R0122650 IMPLICIT REAL*8 (A-H,O-Z) 00122660 DIMENSION A(N,N),B(N,N),X(N,N),EIGV(N),D(N) 00122670 COMMON /EXTRA/ MODEX,NREXTR(25) R0122680 NSMAX=15 00122690 NSWEEP=0 00122700 IEND=0 00122710 130 NSWEEP=NSWEEP+1 00122720 SUMA = 0.0D0 00122730 SUMB = 0.0D0 00122740 DO 20 I = 1, N 00122750 DIAGLA = A(I,I) 00122760 DIAGLB = B(I,I) 00122770 IF(DIAGLA .LT. 1.0D-20) GO TO 10 00122780 DIAGLA = DLOG10(DIAGLA) 00122790 SUMA = SUMA + DIAGLA 00122800 10 IF(DIAGLB .LT. 1.0D-20) GO TO 20 00122810 DIAGLB = DLOG10(DIAGLB) 00122820 SUMB = SUMB + DIAGLB 00122830 20 CONTINUE 00122840 SUMA = SUMA / N 00122850 SUMB = SUMB / N 00122860 IPWRA = -IDINT(SUMA) - 1 00122870 IPWRB = -IDINT(SUMB) - 1 00122880 CONSTA = 10.0D0**IPWRA 00122890 CONSTB = 10.0D0**IPWRB 00122900 CONST = CONSTA / CONSTB 00122910 IF(IFPR .NE. 0) WRITE(6, 430) CONSTA, CONSTB, CONST 00122920 DO 30 I = 1, N 00122930 DO 30 J = 1, N 00122940 A(I, J) = A(I, J)*CONSTA 00122950 30 B(I, J) = B(I, J)*CONSTB 00122960 IF(NSWEEP.GT.1) GO TO 125 00122970 DO 100 I=1,N 00122980 D(I)=A(I,I)/B(I,I) 00122990 100 EIGV(I)=D(I) 00123000 DO 120 I=1,N 00123010 DO 110 J=1,N 00123020 110 X(I,J)=0.D0 00123030 120 X(I,I)=1.0D0 00123040 IF(N.EQ.1) GO TO 382 00123050 NR=N-1 00123060 125 CONTINUE 00123070 IF(IFPR.EQ.1) 00123080 $WRITE (6,390) NSWEEP 00123090 EPS=(0.01E0**NSWEEP)**2 00123100 DO 300 J=1,NR 00123110 JJ=J+1 00123120 DO 300 K=JJ,N 00123130 TT=A(J,K)*A(J,K) 00123140 TB=A(J,J)*A(K,K) 00123150 EPTOLA= DABS(TT/TB) 00123160 TT=B(J,K)*B(J,K) 00123170 TB=B(J,J)*B(K,K) 00123180 EPTOLB=TT/TB 00123190 IF ((EPTOLA.LT.EPS).AND.(EPTOLB.LT.EPS)) GO TO 300 00123200 AKK=A(K,K)*B(J,K)-B(K,K)*A(J,K) 00123210 AJJ=A(J,J)*B(J,K)-B(J,J)*A(J,K) 00123220 AB=A(J,J)*B(K,K)-A(K,K)*B(J,J) 00123230 CHECK=(AB*AB+4.0E0*AKK*AJJ)/4.0E0 00123240 IF (CHECK) 140,140,150 00123250 140 WRITE (6,410) CHECK 00123260 MODEX=1 00123270 RETURN 00123280 150 SQCH= DSQRT(CHECK) 00123290 D1=AB/2.0E0+SQCH 00123300 D2=AB/2.0E0-SQCH 00123310 DEN=D1 00123320 IF ( DABS(D2).GT. DABS(D1)) DEN=D2 00123330 IF (DEN) 170,160,170 00123340 160 CA=0.E0 00123350 CG=-A(J,K)/A(K,K) 00123360 GO TO 180 00123370 170 CA=AKK/DEN 00123380 CG=-AJJ/DEN 00123390 180 IF (N-2) 190,280,190 00123400 190 JP1=J+1 00123410 JM1=J-1 00123420 KP1=K+1 00123430 KM1=K-1 00123440 IF (JM1-1) 220,200,200 00123450 200 DO 210 I=1,JM1 00123460 AJ=A(I,J) 00123470 BJ=B(I,J) 00123480 AK=A(I,K) 00123490 BK=B(I,K) 00123500 A(I,J)=AJ+CG*AK 00123510 B(I,J)=BJ+CG*BK 00123520 A(I,K)=AK+CA*AJ 00123530 210 B(I,K)=BK+CA*BJ 00123540 220 IF (KP1-N) 230,230,250 00123550 230 DO 240 I=KP1,N 00123560 AJ=A(J,I) 00123570 BJ=B(J,I) 00123580 AK=A(K,I) 00123590 BK=B(K,I) 00123600 A(J,I)=AJ+CG*AK 00123610 B(J,I)=BJ+CG*BK 00123620 A(K,I)=AK+CA*AJ 00123630 240 B(K,I)=BK+CA*BJ 00123640 250 IF (JP1-KM1) 260,260,280 00123650 260 DO 270 I=JP1,KM1 00123660 AJ=A(J,I) 00123670 BJ=B(J,I) 00123680 AK=A(I,K) 00123690 BK=B(I,K) 00123700 A(J,I)=AJ+CG*AK 00123710 B(J,I)=BJ+CG*BK 00123720 A(I,K)=AK+CA*AJ 00123730 270 B(I,K)=BK+CA*BJ 00123740 280 AK=A(K,K) 00123750 BK=B(K,K) 00123760 A(K,K)=AK+2*CA*A(J,K)+CA*CA*A(J,J) 00123770 B(K,K)=BK+2*CA*B(J,K)+CA*CA*B(J,J) 00123780 A(J,J)=A(J,J)+2*CG*A(J,K)+CG*CG*AK 00123790 B(J,J)=B(J,J)+2*CG*B(J,K)+CG*CG*BK 00123800 A(J,K)=0.0E0 00123810 B(J,K)=0.0E0 00123820 DO 290 I=1,N 00123830 XJ=X(I,J) 00123840 XK=X(I,K) 00123850 X(I,J)=XJ+CG*XK 00123860 290 X(I,K)=XK+CA*XJ 00123870 300 CONTINUE 00123880 DO 310 I=1,N 00123890 310 EIGV(I)=A(I,I)/B(I,I) 00123900 IF(IFPR.EQ.0) GO TO 320 00123910 WRITE (6,420) 00123920 WRITE (6,400) (EIGV(I),I=1,N) 00123930 320 CONTINUE 00123940 DO 330 I=1,N 00123950 TOL=RTOL*D(I) 00123960 DIF= DABS(EIGV(I)-D(I)) 00123970 IF (DIF.GT.TOL) GO TO 360 00123980 330 CONTINUE 00123990 EPS=RTOL**2 00124000 IEND=0 00124010 DO 340 J=1,NR 00124020 JJ=J+1 00124030 DO 340 K=JJ,N 00124040 TT=A(J,K)*A(J,K) 00124050 TB=A(J,J)*A(K,K) 00124060 EPSA= DABS(TT/TB) 00124070 TT=B(J,K)*B(J,K) 00124080 TB=B(J,J)*B(K,K) 00124090 EPSB=TT/TB 00124100 IF ((EPSA.LT.EPS).AND.(EPSB.LT.EPS)) GO TO 340 00124110 GO TO 360 00124120 340 CONTINUE 00124130 DO 350 I=1,N 00124140 DO 350 J=I,N 00124150 B(J,I)=B(I,J) 00124160 350 A(J,I)=A(I,J) 00124170 IEND=1 00124180 GO TO 382 00124190 360 DO 370 I=1,N 00124200 370 D(I)=EIGV(I) 00124210 IF (NSWEEP.LT.NSMAX) GO TO 1340 00124220 DO 380 I=1,N 00124230 DO 380 J=I,N 00124240 B(J,I)=B(I,J) 00124250 380 A(J,I)=A(I,J) 00124260 1340 CONTINUE 00124270 382 CONTINUE 00124280 RCA = 1.0D0 / CONSTA 00124290 RCB = 1.0D0 / CONSTB 00124300 RC = 1.0D0 / CONST 00124310 DO 386 J = 1, N 00124320 DO 384 I = 1, N 00124330 A(I,J) = A(I,J) * RCA 00124340 B(I,J) = B(I,J) * RCB 00124350 384 CONTINUE 00124360 D(J) = D(J) * RC 00124370 EIGV(J) = EIGV(J) * RC 00124380 386 CONTINUE 00124390 IF(IFPR .EQ. 1) WRITE(6,440) NSWEEP, (EIGV(I), I=1,N) 00124400 IF(IEND.EQ.1) RETURN 00124410 IF(N.EQ.1) RETURN 00124420 IF(NSWEEP.LT.NSMAX) GO TO 130 00124430 RETURN 00124440 390 FORMAT (27H0SWEEP NUMBER IN *JACOBI* =, I4) 00124450 400 FORMAT (1H ,12E11.4) 00124460 410 FORMAT (37H0***ERROR SOLUTION STOP IN *JACOBI*, / 12X, 00124470 $ 8HCHECK = , E20.14 / 1X) 00124480 420 FORMAT (36H0CURRENT EIGENVALUES IN *JACOBI* ARE, / 1X) 00124490 430 FORMAT (//5X,28HMATRICES SCALING FACTORS A:, D12.4, 00124500 * 5H B:, D12.4, 9H RATIO:, D12.4) 00124510 440 FORMAT(1X, 5HAFTER,I3, 34H SWEEP IN *JACOBI* THE EIGENVALUES, 00124520 * 4H ARE,/ (1H ,10D13.4) ) 00124530 END 00124540 SUBROUTINE SCHECK ( A,XM,BUP,BLO,BUPC,NEIV,NWA,NEQB, R0224420 $NBLOCK,NF,NV,SHIFT,NEI,IFPR,RTOL,NWMA) 00224430 IMPLICIT REAL*8 (A-H,O-Z) 00224440 COMMON /EXTRA/ MODEX,NREXTR(25) R0224450 COMMON /MASS/ LMASS 00224460 COMMON /SQZ/ ISQZ,NRSQZ(5) R0224470 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00224480 COMMON /AAA2/ DL(200),RTOLV(200) R0224481 DIMENSION A(NWA),XM(NWMA),BUP(NV),BLO(NV),BUPC(NV) R0224490 CC $RTOLV(NV) R0224500 INTEGER NEIV(NV) 00224510 FTOL=1.0E-02 00224520 FTOL1=1.0E0+FTOL 00224530 FTOL2=1.0E0-FTOL 00224540 DO 100 I=1,NV 00224550 BUP(I)=DL(I)*FTOL1 00224560 100 BLO(I)=DL(I)*FTOL2 00224570 NROOT=0 00224580 DO 110 I=1,NF 00224590 110 IF (RTOLV(I).LT.RTOL) NROOT=NROOT+1 00224600 IF (NROOT.GE.1) GO TO 120 00224610 WRITE (6,290) 00224620 MODEX=1 00224630 RETURN 00224640 120 DO 130 I=1,NROOT 00224650 130 NEIV(I)=1 00224660 IF (NROOT.NE.1) GO TO 140 00224670 BUPC(1)=BUP(1) 00224680 LM=1 00224690 L=1 00224700 I=2 00224710 GO TO 180 00224720 140 L=1 00224730 I=2 00224740 150 IF (BUP(I-1).LE.BLO(I)) GO TO 160 00224750 NEIV(L)=NEIV(L)+1 00224760 I=I+1 00224770 IF (I.LE.NROOT) GO TO 150 00224780 160 BUPC(L)=BUP(I-1) 00224790 IF (I.GT.NROOT) GO TO 170 00224800 L=L+1 00224810 I=I+1 00224820 IF (I.LE.NROOT) GO TO 150 00224830 BUPC(L)=BUP(I-1) 00224840 170 LM=L 00224850 180 IF (BUP(I-1).LE.BLO(I)) GO TO 190 00224860 IF (RTOLV(I).GT.RTOL) GO TO 190 00224870 BUPC(L)=BUP(I) 00224880 NEIV(L)=NEIV(L)+1 00224890 NROOT=NROOT+1 00224900 IF (NROOT.EQ.NV) GO TO 190 00224910 I=I+1 00224920 GO TO 180 00224930 190 WRITE (6,300) 00224940 WRITE (6,270) (BUPC(I),I=1,LM) 00224950 WRITE (6,310) 00224960 WRITE (6,280) (NEIV(I),I=1,LM) 00224970 LL=LM-1 00224980 IF (LM.EQ.1) GO TO 220 00224990 200 DO 210 I=1,LL 00225000 210 NEIV(L)=NEIV(L)+NEIV(I) 00225010 L=L-1 00225020 LL=LL-1 00225030 IF (L.NE.1) GO TO 200 00225040 WRITE (6,320) 00225050 WRITE (6,280) (NEIV(I),I=1,LM) 00225060 220 DO 230 I=1,LM 00225070 IF (NEIV(I).GE.NROOT) GO TO 240 00225080 230 CONTINUE 00225090 240 SHIFT=BUPC(I) 00225100 NEI=NEIV(I) 00225110 CALL RDWRT(NRED ,A,1,6,I) 00225120 CALL RDWRT(NSTIF,A,1,6,I) 00225130 REWIND NMASS 00225140 DO 260 L=1,NBLOCK 00225150 CALL EXPAND(A,NWA,NSTIF) 00225160 READ (NMASS) XM 00225170 LBKS=4*NWMA 00225180 LRDS=4*(NWMA+NEQB) 00225190 IF(LMASS.EQ.1) GO TO 250 00225200 CALL QMR2(A,A,SHIFT,XM,NEQB,1,1,1) 00225210 GO TO 255 00225220 250 CALL QMR3(A,A,SHIFT,XM,NEQB,1,1,1,NWA) 00225230 255 CONTINUE 00225240 CALL SQEEZE(A,NWA,NRED,ISQZ ) 00225250 260 CONTINUE 00225260 I=NSTIF 00225270 NSTIF=NRED 00225280 NRED=I 00225290 RETURN 00225300 270 FORMAT (1H0,6E22.14) 00225310 280 FORMAT (1H0,6I22) 00225320 290 FORMAT (37H0***ERROR SOLUTION STOP IN *SCHECK*, / 12X, 00225330 $ 21HNO EIGENVALUES FOUND., / 1X) 00225340 300 FORMAT (37H0UPPER BOUNDS ON EIGENVALUE CLUSTERS ) 00225350 310 FORMAT (34H0NO OF EIGENVALUES IN EACH CLUSTER ) 00225360 320 FORMAT (42H0NO OF EIGENVALUES LESS THAN UPPER BOUNDS ) 00225370 END 00225380