cdrvsg.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,291 行 · 第 1/4 页

*
*              loop over the setting UPLO
*
               DO 620 IBUPLO = 1, 2
                  IF( IBUPLO.EQ.1 )
     $               UPLO = 'U'
                  IF( IBUPLO.EQ.2 )
     $               UPLO = 'L'
*
*                 Generate random well-conditioned positive definite
*                 matrix B, of bandwidth not greater than that of A.
*
                  CALL CLATMS( N, N, 'U', ISEED, 'P', RWORK, 5, TEN,
     $                         ONE, KB, KB, UPLO, B, LDB, WORK( N+1 ),
     $                         IINFO )
*
*                 Test CHEGV
*
                  NTEST = NTEST + 1
*
                  CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ )
                  CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
                  CALL CHEGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
     $                        WORK, NWORK, RWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHEGV(V,' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 100
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
*                 Test CHEGVD
*
                  NTEST = NTEST + 1
*
                  CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ )
                  CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
                  CALL CHEGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
     $                         WORK, NWORK, RWORK, LRWORK, IWORK,
     $                         LIWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHEGVD(V,' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 100
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
*                 Test CHEGVX
*
                  NTEST = NTEST + 1
*
                  CALL CLACPY( ' ', N, N, A, LDA, AB, LDA )
                  CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
                  CALL CHEGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB,
     $                         LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
     $                         LDZ, WORK, NWORK, RWORK, IWORK( N+1 ),
     $                         IWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,A' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 100
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
                  NTEST = NTEST + 1
*
                  CALL CLACPY( ' ', N, N, A, LDA, AB, LDA )
                  CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
*                 since we do not know the exact eigenvalues of this
*                 eigenpair, we just set VL and VU as constants.
*                 It is quite possible that there are no eigenvalues
*                 in this interval.
*
                  VL = ZERO
                  VU = ANORM
                  CALL CHEGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB,
     $                         LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
     $                         LDZ, WORK, NWORK, RWORK, IWORK( N+1 ),
     $                         IWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,V,' //
     $                  UPLO // ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 100
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
                  NTEST = NTEST + 1
*
                  CALL CLACPY( ' ', N, N, A, LDA, AB, LDA )
                  CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
                  CALL CHEGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB,
     $                         LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
     $                         LDZ, WORK, NWORK, RWORK, IWORK( N+1 ),
     $                         IWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,I,' //
     $                  UPLO // ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 100
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
  100             CONTINUE
*
*                 Test CHPGV
*
                  NTEST = NTEST + 1
*
*                 Copy the matrices into packed storage.
*
                  IF( LSAME( UPLO, 'U' ) ) THEN
                     IJ = 1
                     DO 120 J = 1, N
                        DO 110 I = 1, J
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  110                   CONTINUE
  120                CONTINUE
                  ELSE
                     IJ = 1
                     DO 140 J = 1, N
                        DO 130 I = J, N
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  130                   CONTINUE
  140                CONTINUE
                  END IF
*
                  CALL CHPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
     $                        WORK, RWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHPGV(V,' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 310
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
*                 Test CHPGVD
*
                  NTEST = NTEST + 1
*
*                 Copy the matrices into packed storage.
*
                  IF( LSAME( UPLO, 'U' ) ) THEN
                     IJ = 1
                     DO 160 J = 1, N
                        DO 150 I = 1, J
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  150                   CONTINUE
  160                CONTINUE
                  ELSE
                     IJ = 1
                     DO 180 J = 1, N
                        DO 170 I = J, N
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  170                   CONTINUE
  180                CONTINUE
                  END IF
*
                  CALL CHPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
     $                         WORK, NWORK, RWORK, LRWORK, IWORK,
     $                         LIWORK, IINFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHPGVD(V,' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 310
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
*                 Test CHPGVX
*
                  NTEST = NTEST + 1
*
*                 Copy the matrices into packed storage.
*
                  IF( LSAME( UPLO, 'U' ) ) THEN
                     IJ = 1
                     DO 200 J = 1, N
                        DO 190 I = 1, J
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  190                   CONTINUE
  200                CONTINUE
                  ELSE
                     IJ = 1
                     DO 220 J = 1, N
                        DO 210 I = J, N
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  210                   CONTINUE
  220                CONTINUE
                  END IF
*
                  CALL CHPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL,
     $                         VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
     $                         RWORK, IWORK( N+1 ), IWORK, INFO )
                  IF( IINFO.NE.0 ) THEN
                     WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,A' // UPLO //
     $                  ')', IINFO, N, JTYPE, IOLDSD
                     INFO = ABS( IINFO )
                     IF( IINFO.LT.0 ) THEN
                        RETURN
                     ELSE
                        RESULT( NTEST ) = ULPINV
                        GO TO 310
                     END IF
                  END IF
*
*                 Do Test
*
                  CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
     $                         LDZ, D, WORK, RWORK, RESULT( NTEST ) )
*
                  NTEST = NTEST + 1
*
*                 Copy the matrices into packed storage.
*
                  IF( LSAME( UPLO, 'U' ) ) THEN
                     IJ = 1
                     DO 240 J = 1, N
                        DO 230 I = 1, J
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  230                   CONTINUE
  240                CONTINUE
                  ELSE
                     IJ = 1
                     DO 260 J = 1, N
                        DO 250 I = J, N
                           AP( IJ ) = A( I, J )
                           BP( IJ ) = B( I, J )
                           IJ = IJ + 1
  250                   CONTINUE
  260                CONTINUE
                  END IF
*
                  VL = ZERO
                  VU = ANORM
                  CALL CHPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL,
     $                         VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,