subroutine zdrvsp	(	logical, dimension( * )	DOTYPE,
		integer	NN,
		integer, dimension( * )	NVAL,
		integer	NRHS,
		double precision	THRESH,
		logical	TSTERR,
		integer	NMAX,
		complex*16, dimension( * )	A,
		complex*16, dimension( * )	AFAC,
		complex*16, dimension( * )	AINV,
		complex*16, dimension( * )	B,
		complex*16, dimension( * )	X,
		complex*16, dimension( * )	XACT,
		complex*16, dimension( * )	WORK,
		double precision, dimension( * )	RWORK,
		integer, dimension( * )	IWORK,
		integer	NOUT
	)

ZDRVSP

Purpose:

 ZDRVSP tests the driver routines ZSPSV and -SVX.

Parameters

[in]	DOTYPE	DOTYPE is LOGICAL array, dimension (NTYPES) The matrix types to be used for testing. Matrices of type j (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]	NN	NN is INTEGER The number of values of N contained in the vector NVAL.
[in]	NVAL	NVAL is INTEGER array, dimension (NN) The values of the matrix dimension N.
[in]	NRHS	NRHS is INTEGER The number of right hand side vectors to be generated for each linear system.
[in]	THRESH	THRESH is DOUBLE PRECISION The threshold value for the test ratios. A result is included in the output file if RESULT >= THRESH. To have every test ratio printed, use THRESH = 0.
[in]	TSTERR	TSTERR is LOGICAL Flag that indicates whether error exits are to be tested.
[in]	NMAX	NMAX is INTEGER The maximum value permitted for N, used in dimensioning the work arrays.
[out]	A	A is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
[out]	AFAC	AFAC is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
[out]	AINV	AINV is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
[out]	B	B is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]	X	X is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]	XACT	XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]	WORK	WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
[out]	RWORK	RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
[out]	IWORK	IWORK is INTEGER array, dimension (NMAX)
[in]	NOUT	NOUT is INTEGER The unit number for output.

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Date

November 2011

Definition at line 159 of file zdrvsp.f.

*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      LOGICAL            tsterr
      INTEGER            nmax, nn, nout, nrhs
      DOUBLE PRECISION   thresh
*     ..
*     .. Array Arguments ..
      LOGICAL            dotype( * )
      INTEGER            iwork( * ), nval( * )
      DOUBLE PRECISION   rwork( * )
      COMPLEX*16         a( * ), afac( * ), ainv( * ), b( * ),
     $                   work( * ), x( * ), xact( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   one, zero
      parameter                ( one = 1.0d+0, zero = 0.0d+0 )
      INTEGER            ntypes, ntests
      parameter                ( ntypes = 11, ntests = 6 )
      INTEGER            nfact
      parameter                ( nfact = 2 )
*     ..
*     .. Local Scalars ..
      LOGICAL            zerot
      CHARACTER          dist, fact, packit, TYPE, uplo, xtype
      CHARACTER*3        path
      INTEGER            i, i1, i2, ifact, imat, in, info, ioff, iuplo,
     $                   izero, j, k, k1, kl, ku, lda, mode, n, nb,
     $                   nbmin, nerrs, nfail, nimat, npp, nrun, nt
      DOUBLE PRECISION   ainvnm, anorm, cndnum, rcond, rcondc
*     ..
*     .. Local Arrays ..
      CHARACTER          facts( nfact )
      INTEGER            iseed( 4 ), iseedy( 4 )
      DOUBLE PRECISION   result( ntests )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   dget06, zlansp
      EXTERNAL           dget06, zlansp
*     ..
*     .. External Subroutines ..
      EXTERNAL           aladhd, alaerh, alasvm, xlaenv, zcopy, zerrvx,
     $                   zget04, zlacpy, zlarhs, zlaset, zlatb4, zlatms,
     $                   zlatsp, zppt05, zspsv, zspsvx, zspt01, zspt02,
     $                   zsptrf, zsptri
*     ..
*     .. Scalars in Common ..
      LOGICAL            lerr, ok
      CHARACTER*32       srnamt
      INTEGER            infot, nunit
*     ..
*     .. Common blocks ..
      COMMON             / infoc / infot, nunit, ok, lerr
      COMMON             / srnamc / srnamt
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dcmplx, max, min
*     ..
*     .. Data statements ..
      DATA               iseedy / 1988, 1989, 1990, 1991 /
      DATA               facts / 'F', 'N' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      path( 1: 1 ) = 'Zomplex precision'
      path( 2: 3 ) = 'SP'
      nrun = 0
      nfail = 0
      nerrs = 0
      DO 10 i = 1, 4
         iseed( i ) = iseedy( i )
   10 CONTINUE
*
*     Test the error exits
*
      IF( tsterr )
     $   CALL zerrvx( path, nout )
      infot = 0
*
*     Set the block size and minimum block size for testing.
*
      nb = 1
      nbmin = 2
      CALL xlaenv( 1, nb )
      CALL xlaenv( 2, nbmin )
*
*     Do for each value of N in NVAL
*
      DO 180 in = 1, nn
         n = nval( in )
         lda = max( n, 1 )
         npp = n*( n+1 ) / 2
         xtype = 'N'
         nimat = ntypes
         IF( n.LE.0 )
     $      nimat = 1
*
         DO 170 imat = 1, nimat
*
*           Do the tests only if DOTYPE( IMAT ) is true.
*
            IF( .NOT.dotype( imat ) )
     $         GO TO 170
*
*           Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
            zerot = imat.GE.3 .AND. imat.LE.6
            IF( zerot .AND. n.LT.imat-2 )
     $         GO TO 170
*
*           Do first for UPLO = 'U', then for UPLO = 'L'
*
            DO 160 iuplo = 1, 2
               IF( iuplo.EQ.1 ) THEN
                  uplo = 'U'
                  packit = 'C'
               ELSE
                  uplo = 'L'
                  packit = 'R'
               END IF
*
               IF( imat.NE.ntypes ) THEN
*
*                 Set up parameters with ZLATB4 and generate a test
*                 matrix with ZLATMS.
*
                  CALL zlatb4( path, imat, n, n, TYPE, kl, ku, anorm,
     $                         mode, cndnum, dist )
*
                  srnamt = 'ZLATMS'
                  CALL zlatms( n, n, dist, iseed, TYPE, rwork, mode,
     $                         cndnum, anorm, kl, ku, packit, a, lda,
     $                         work, info )
*
*                 Check error code from ZLATMS.
*
                  IF( info.NE.0 ) THEN
                     CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
     $                            -1, -1, -1, imat, nfail, nerrs, nout )
                     GO TO 160
                  END IF
*
*                 For types 3-6, zero one or more rows and columns of
*                 the matrix to test that INFO is returned correctly.
*
                  IF( zerot ) THEN
                     IF( imat.EQ.3 ) THEN
                        izero = 1
                     ELSE IF( imat.EQ.4 ) THEN
                        izero = n
                     ELSE
                        izero = n / 2 + 1
                     END IF
*
                     IF( imat.LT.6 ) THEN
*
*                       Set row and column IZERO to zero.
*
                        IF( iuplo.EQ.1 ) THEN
                           ioff = ( izero-1 )*izero / 2
                           DO 20 i = 1, izero - 1
                              a( ioff+i ) = zero
   20                      CONTINUE
                           ioff = ioff + izero
                           DO 30 i = izero, n
                              a( ioff ) = zero
                              ioff = ioff + i
   30                      CONTINUE
                        ELSE
                           ioff = izero
                           DO 40 i = 1, izero - 1
                              a( ioff ) = zero
                              ioff = ioff + n - i
   40                      CONTINUE
                           ioff = ioff - izero
                           DO 50 i = izero, n
                              a( ioff+i ) = zero
   50                      CONTINUE
                        END IF
                     ELSE
                        IF( iuplo.EQ.1 ) THEN
*
*                          Set the first IZERO rows and columns to zero.
*
                           ioff = 0
                           DO 70 j = 1, n
                              i2 = min( j, izero )
                              DO 60 i = 1, i2
                                 a( ioff+i ) = zero
   60                         CONTINUE
                              ioff = ioff + j
   70                      CONTINUE
                        ELSE
*
*                          Set the last IZERO rows and columns to zero.
*
                           ioff = 0
                           DO 90 j = 1, n
                              i1 = max( j, izero )
                              DO 80 i = i1, n
                                 a( ioff+i ) = zero
   80                         CONTINUE
                              ioff = ioff + n - j
   90                      CONTINUE
                        END IF
                     END IF
                  ELSE
                     izero = 0
                  END IF
               ELSE
*
*                 Use a special block diagonal matrix to test alternate
*                 code for the 2-by-2 blocks.
*
                  CALL zlatsp( uplo, n, a, iseed )
               END IF
*
               DO 150 ifact = 1, nfact
*
*                 Do first for FACT = 'F', then for other values.
*
                  fact = facts( ifact )
*
*                 Compute the condition number for comparison with
*                 the value returned by ZSPSVX.
*
                  IF( zerot ) THEN
                     IF( ifact.EQ.1 )
     $                  GO TO 150
                     rcondc = zero
*
                  ELSE IF( ifact.EQ.1 ) THEN
*
*                    Compute the 1-norm of A.
*
                     anorm = zlansp( '1', uplo, n, a, rwork )
*
*                    Factor the matrix A.
*
                     CALL zcopy( npp, a, 1, afac, 1 )
                     CALL zsptrf( uplo, n, afac, iwork, info )
*
*                    Compute inv(A) and take its norm.
*
                     CALL zcopy( npp, afac, 1, ainv, 1 )
                     CALL zsptri( uplo, n, ainv, iwork, work, info )
                     ainvnm = zlansp( '1', uplo, n, ainv, rwork )
*
*                    Compute the 1-norm condition number of A.
*
                     IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
                        rcondc = one
                     ELSE
                        rcondc = ( one / anorm ) / ainvnm
                     END IF
                  END IF
*
*                 Form an exact solution and set the right hand side.
*
                  srnamt = 'ZLARHS'
                  CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
     $                         nrhs, a, lda, xact, lda, b, lda, iseed,
     $                         info )
                  xtype = 'C'
*
*                 --- Test ZSPSV  ---
*
                  IF( ifact.EQ.2 ) THEN
                     CALL zcopy( npp, a, 1, afac, 1 )
                     CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
*
*                    Factor the matrix and solve the system using ZSPSV.
*
                     srnamt = 'ZSPSV '
                     CALL zspsv( uplo, n, nrhs, afac, iwork, x, lda,
     $                           info )
*
*                    Adjust the expected value of INFO to account for
*                    pivoting.
*
                     k = izero
                     IF( k.GT.0 ) THEN
  100                   CONTINUE
                        IF( iwork( k ).LT.0 ) THEN
                           IF( iwork( k ).NE.-k ) THEN
                              k = -iwork( k )
                              GO TO 100
                           END IF
                        ELSE IF( iwork( k ).NE.k ) THEN
                           k = iwork( k )
                           GO TO 100
                        END IF
                     END IF
*
*                    Check error code from ZSPSV .
*
                     IF( info.NE.k ) THEN
                        CALL alaerh( path, 'ZSPSV ', info, k, uplo, n,
     $                               n, -1, -1, nrhs, imat, nfail,
     $                               nerrs, nout )
                        GO TO 120
                     ELSE IF( info.NE.0 ) THEN
                        GO TO 120
                     END IF
*
*                    Reconstruct matrix from factors and compute
*                    residual.
*
                     CALL zspt01( uplo, n, a, afac, iwork, ainv, lda,
     $                            rwork, result( 1 ) )
*
*                    Compute residual of the computed solution.
*
                     CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
                     CALL zspt02( uplo, n, nrhs, a, x, lda, work, lda,
     $                            rwork, result( 2 ) )
*
*                    Check solution from generated exact solution.
*
                     CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
     $                            result( 3 ) )
                     nt = 3
*
*                    Print information about the tests that did not pass
*                    the threshold.
*
                     DO 110 k = 1, nt
                        IF( result( k ).GE.thresh ) THEN
                           IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
     $                        CALL aladhd( nout, path )
                           WRITE( nout, fmt = 9999 )'ZSPSV ', uplo, n,
     $                        imat, k, result( k )
                           nfail = nfail + 1
                        END IF
  110                CONTINUE
                     nrun = nrun + nt
  120                CONTINUE
                  END IF
*
*                 --- Test ZSPSVX ---
*
                  IF( ifact.EQ.2 .AND. npp.GT.0 )
     $               CALL zlaset( 'Full', npp, 1, dcmplx( zero ),
     $                            dcmplx( zero ), afac, npp )
                  CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
     $                         dcmplx( zero ), x, lda )
*
*                 Solve the system and compute the condition number and
*                 error bounds using ZSPSVX.
*
                  srnamt = 'ZSPSVX'
                  CALL zspsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
     $                         lda, x, lda, rcond, rwork,
     $                         rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
     $                         info )
*
*                 Adjust the expected value of INFO to account for
*                 pivoting.
*
                  k = izero
                  IF( k.GT.0 ) THEN
  130                CONTINUE
                     IF( iwork( k ).LT.0 ) THEN
                        IF( iwork( k ).NE.-k ) THEN
                           k = -iwork( k )
                           GO TO 130
                        END IF
                     ELSE IF( iwork( k ).NE.k ) THEN
                        k = iwork( k )
                        GO TO 130
                     END IF
                  END IF
*
*                 Check the error code from ZSPSVX.
*
                  IF( info.NE.k ) THEN
                     CALL alaerh( path, 'ZSPSVX', info, k, fact // uplo,
     $                            n, n, -1, -1, nrhs, imat, nfail,
     $                            nerrs, nout )
                     GO TO 150
                  END IF
*
                  IF( info.EQ.0 ) THEN
                     IF( ifact.GE.2 ) THEN
*
*                       Reconstruct matrix from factors and compute
*                       residual.
*
                        CALL zspt01( uplo, n, a, afac, iwork, ainv, lda,
     $                               rwork( 2*nrhs+1 ), result( 1 ) )
                        k1 = 1
                     ELSE
                        k1 = 2
                     END IF
*
*                    Compute residual of the computed solution.
*
                     CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
                     CALL zspt02( uplo, n, nrhs, a, x, lda, work, lda,
     $                            rwork( 2*nrhs+1 ), result( 2 ) )
*
*                    Check solution from generated exact solution.
*
                     CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
     $                            result( 3 ) )
*
*                    Check the error bounds from iterative refinement.
*
                     CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda,
     $                            xact, lda, rwork, rwork( nrhs+1 ),
     $                            result( 4 ) )
                  ELSE
                     k1 = 6
                  END IF
*
*                 Compare RCOND from ZSPSVX with the computed value
*                 in RCONDC.
*
                  result( 6 ) = dget06( rcond, rcondc )
*
*                 Print information about the tests that did not pass
*                 the threshold.
*
                  DO 140 k = k1, 6
                     IF( result( k ).GE.thresh ) THEN
                        IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
     $                     CALL aladhd( nout, path )
                        WRITE( nout, fmt = 9998 )'ZSPSVX', fact, uplo,
     $                     n, imat, k, result( k )
                        nfail = nfail + 1
                     END IF
  140             CONTINUE
                  nrun = nrun + 7 - k1
*
  150          CONTINUE
*
  160       CONTINUE
  170    CONTINUE
  180 CONTINUE
*
*     Print a summary of the results.
*
      CALL alasvm( path, nout, nfail, nrun, nerrs )
*
 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
     $      ', test ', i2, ', ratio =', g12.5 )
 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
     $      ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
      RETURN
*
*     End of ZDRVSP
*

Here is the call graph for this function:

Here is the caller graph for this function: