      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
