You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
318 lines
12 KiB
318 lines
12 KiB
2 years ago
|
*> \brief \b ZSYL01
|
||
|
|
*
|
||
|
|
* =========== DOCUMENTATION ===========
|
||
|
|
*
|
||
|
|
* Online html documentation available at
|
||
|
|
* http://www.netlib.org/lapack/explore-html/
|
||
|
|
*
|
||
|
|
* Definition:
|
||
|
|
* ===========
|
||
|
|
*
|
||
|
|
* SUBROUTINE ZSYL01( THRESH, NFAIL, RMAX, NINFO, KNT )
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
* INTEGER KNT
|
||
|
|
* DOUBLE PRECISION THRESH
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
* INTEGER NFAIL( 3 ), NINFO( 2 )
|
||
|
|
* DOUBLE PRECISION RMAX( 2 )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*> \par Purpose:
|
||
|
|
* =============
|
||
|
|
*>
|
||
|
|
*> \verbatim
|
||
|
|
*>
|
||
|
|
*> ZSYL01 tests ZTRSYL and ZTRSYL3, routines for solving the Sylvester matrix
|
||
|
|
*> equation
|
||
|
|
*>
|
||
|
|
*> op(A)*X + ISGN*X*op(B) = scale*C,
|
||
|
|
*>
|
||
|
|
*> where op(A) and op(B) are both upper triangular form, op() represents an
|
||
|
|
*> optional conjugate transpose, and ISGN can be -1 or +1. Scale is an output
|
||
|
|
*> less than or equal to 1, chosen to avoid overflow in X.
|
||
|
|
*>
|
||
|
|
*> The test code verifies that the following residual does not exceed
|
||
|
|
*> the provided threshold:
|
||
|
|
*>
|
||
|
|
*> norm(op(A)*X + ISGN*X*op(B) - scale*C) /
|
||
|
|
*> (EPS*max(norm(A),norm(B))*norm(X))
|
||
|
|
*>
|
||
|
|
*> This routine complements ZGET35 by testing with larger,
|
||
|
|
*> random matrices, of which some require rescaling of X to avoid overflow.
|
||
|
|
*>
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Arguments:
|
||
|
|
* ==========
|
||
|
|
*
|
||
|
|
*> \param[in] THRESH
|
||
|
|
*> \verbatim
|
||
|
|
*> THRESH is DOUBLE PRECISION
|
||
|
|
*> A test will count as "failed" if the residual, computed as
|
||
|
|
*> described above, exceeds THRESH.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] NFAIL
|
||
|
|
*> \verbatim
|
||
|
|
*> NFAIL is INTEGER array, dimension (3)
|
||
|
|
*> NFAIL(1) = No. of times residual ZTRSYL exceeds threshold THRESH
|
||
|
|
*> NFAIL(2) = No. of times residual ZTRSYL3 exceeds threshold THRESH
|
||
|
|
*> NFAIL(3) = No. of times ZTRSYL3 and ZTRSYL deviate
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] RMAX
|
||
|
|
*> \verbatim
|
||
|
|
*> RMAX is DOUBLE PRECISION array, dimension (2)
|
||
|
|
*> RMAX(1) = Value of the largest test ratio of ZTRSYL
|
||
|
|
*> RMAX(2) = Value of the largest test ratio of ZTRSYL3
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] NINFO
|
||
|
|
*> \verbatim
|
||
|
|
*> NINFO is INTEGER array, dimension (2)
|
||
|
|
*> NINFO(1) = No. of times ZTRSYL returns an expected INFO
|
||
|
|
*> NINFO(2) = No. of times ZTRSYL3 returns an expected INFO
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] KNT
|
||
|
|
*> \verbatim
|
||
|
|
*> KNT is INTEGER
|
||
|
|
*> Total number of examples tested.
|
||
|
|
*> \endverbatim
|
||
|
|
|
||
|
|
*
|
||
|
|
* -- LAPACK test routine --
|
||
|
|
SUBROUTINE ZSYL01( THRESH, NFAIL, RMAX, NINFO, KNT )
|
||
|
|
IMPLICIT NONE
|
||
|
|
*
|
||
|
|
* -- LAPACK test routine --
|
||
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
INTEGER KNT
|
||
|
|
DOUBLE PRECISION THRESH
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
INTEGER NFAIL( 3 ), NINFO( 2 )
|
||
|
|
DOUBLE PRECISION RMAX( 2 )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
* ..
|
||
|
|
* .. Parameters ..
|
||
|
|
COMPLEX*16 CONE
|
||
|
|
PARAMETER ( CONE = ( 1.0D0, 0.0D+0 ) )
|
||
|
|
DOUBLE PRECISION ONE, ZERO
|
||
|
|
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
|
||
|
|
INTEGER MAXM, MAXN, LDSWORK
|
||
|
|
PARAMETER ( MAXM = 185, MAXN = 192, LDSWORK = 36 )
|
||
|
|
* ..
|
||
|
|
* .. Local Scalars ..
|
||
|
|
CHARACTER TRANA, TRANB
|
||
|
|
INTEGER I, INFO, IINFO, ISGN, ITRANA, ITRANB, J, KLA,
|
||
|
|
$ KUA, KLB, KUB, M, N
|
||
|
|
DOUBLE PRECISION ANRM, BNRM, BIGNUM, EPS, RES, RES1,
|
||
|
|
$ SCALE, SCALE3, SMLNUM, TNRM, XNRM
|
||
|
|
COMPLEX*16 RMUL
|
||
|
|
* ..
|
||
|
|
* .. Local Arrays ..
|
||
|
|
COMPLEX*16 DUML( MAXM ), DUMR( MAXN ),
|
||
|
|
$ D( MAX( MAXM, MAXN ) )
|
||
|
|
DOUBLE PRECISION DUM( MAXN ), VM( 2 )
|
||
|
|
INTEGER ISEED( 4 ), IWORK( MAXM + MAXN + 2 )
|
||
|
|
* ..
|
||
|
|
* .. Allocatable Arrays ..
|
||
|
|
INTEGER AllocateStatus
|
||
|
|
COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: A, B, C, CC, X
|
||
|
|
DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: SWORK
|
||
|
|
* ..
|
||
|
|
* .. External Functions ..
|
||
|
|
LOGICAL DISNAN
|
||
|
|
DOUBLE PRECISION DLAMCH, ZLANGE
|
||
|
|
EXTERNAL DISNAN, DLAMCH, ZLANGE
|
||
|
|
* ..
|
||
|
|
* .. External Subroutines ..
|
||
|
|
EXTERNAL ZLATMR, ZLACPY, ZGEMM, ZTRSYL, ZTRSYL3
|
||
|
|
* ..
|
||
|
|
* .. Intrinsic Functions ..
|
||
|
|
INTRINSIC ABS, DBLE, MAX, SQRT
|
||
|
|
* ..
|
||
|
|
* .. Allocate memory dynamically ..
|
||
|
|
ALLOCATE ( A( MAXM, MAXM ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
ALLOCATE ( B( MAXN, MAXN ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
ALLOCATE ( C( MAXM, MAXN ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
ALLOCATE ( CC( MAXM, MAXN ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
ALLOCATE ( X( MAXM, MAXN ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
ALLOCATE ( SWORK( LDSWORK, 103 ), STAT = AllocateStatus )
|
||
|
|
IF( AllocateStatus /= 0 ) STOP "*** Not enough memory ***"
|
||
|
|
* ..
|
||
|
|
* .. Executable Statements ..
|
||
|
|
*
|
||
|
|
* Get machine parameters
|
||
|
|
*
|
||
|
|
EPS = DLAMCH( 'P' )
|
||
|
|
SMLNUM = DLAMCH( 'S' ) / EPS
|
||
|
|
BIGNUM = ONE / SMLNUM
|
||
|
|
*
|
||
|
|
* Expect INFO = 0
|
||
|
|
VM( 1 ) = ONE
|
||
|
|
* Expect INFO = 1
|
||
|
|
VM( 2 ) = 0.05D+0
|
||
|
|
*
|
||
|
|
* Begin test loop
|
||
|
|
*
|
||
|
|
NINFO( 1 ) = 0
|
||
|
|
NINFO( 2 ) = 0
|
||
|
|
NFAIL( 1 ) = 0
|
||
|
|
NFAIL( 2 ) = 0
|
||
|
|
NFAIL( 3 ) = 0
|
||
|
|
RMAX( 1 ) = ZERO
|
||
|
|
RMAX( 2 ) = ZERO
|
||
|
|
KNT = 0
|
||
|
|
ISEED( 1 ) = 1
|
||
|
|
ISEED( 2 ) = 1
|
||
|
|
ISEED( 3 ) = 1
|
||
|
|
ISEED( 4 ) = 1
|
||
|
|
SCALE = ONE
|
||
|
|
SCALE3 = ONE
|
||
|
|
DO J = 1, 2
|
||
|
|
DO ISGN = -1, 1, 2
|
||
|
|
* Reset seed (overwritten by LATMR)
|
||
|
|
ISEED( 1 ) = 1
|
||
|
|
ISEED( 2 ) = 1
|
||
|
|
ISEED( 3 ) = 1
|
||
|
|
ISEED( 4 ) = 1
|
||
|
|
DO M = 32, MAXM, 51
|
||
|
|
KLA = 0
|
||
|
|
KUA = M - 1
|
||
|
|
CALL ZLATMR( M, M, 'S', ISEED, 'N', D,
|
||
|
|
$ 6, ONE, CONE, 'T', 'N',
|
||
|
|
$ DUML, 1, ONE, DUMR, 1, ONE,
|
||
|
|
$ 'N', IWORK, KLA, KUA, ZERO,
|
||
|
|
$ ONE, 'NO', A, MAXM, IWORK,
|
||
|
|
$ IINFO )
|
||
|
|
DO I = 1, M
|
||
|
|
A( I, I ) = A( I, I ) * VM( J )
|
||
|
|
END DO
|
||
|
|
ANRM = ZLANGE( 'M', M, M, A, MAXM, DUM )
|
||
|
|
DO N = 51, MAXN, 47
|
||
|
|
KLB = 0
|
||
|
|
KUB = N - 1
|
||
|
|
CALL ZLATMR( N, N, 'S', ISEED, 'N', D,
|
||
|
|
$ 6, ONE, CONE, 'T', 'N',
|
||
|
|
$ DUML, 1, ONE, DUMR, 1, ONE,
|
||
|
|
$ 'N', IWORK, KLB, KUB, ZERO,
|
||
|
|
$ ONE, 'NO', B, MAXN, IWORK,
|
||
|
|
$ IINFO )
|
||
|
|
DO I = 1, N
|
||
|
|
B( I, I ) = B( I, I ) * VM ( J )
|
||
|
|
END DO
|
||
|
|
BNRM = ZLANGE( 'M', N, N, B, MAXN, DUM )
|
||
|
|
TNRM = MAX( ANRM, BNRM )
|
||
|
|
CALL ZLATMR( M, N, 'S', ISEED, 'N', D,
|
||
|
|
$ 6, ONE, CONE, 'T', 'N',
|
||
|
|
$ DUML, 1, ONE, DUMR, 1, ONE,
|
||
|
|
$ 'N', IWORK, M, N, ZERO, ONE,
|
||
|
|
$ 'NO', C, MAXM, IWORK, IINFO )
|
||
|
|
DO ITRANA = 1, 2
|
||
|
|
IF( ITRANA.EQ.1 )
|
||
|
|
$ TRANA = 'N'
|
||
|
|
IF( ITRANA.EQ.2 )
|
||
|
|
$ TRANA = 'C'
|
||
|
|
DO ITRANB = 1, 2
|
||
|
|
IF( ITRANB.EQ.1 )
|
||
|
|
$ TRANB = 'N'
|
||
|
|
IF( ITRANB.EQ.2 )
|
||
|
|
$ TRANB = 'C'
|
||
|
|
KNT = KNT + 1
|
||
|
|
*
|
||
|
|
CALL ZLACPY( 'All', M, N, C, MAXM, X, MAXM)
|
||
|
|
CALL ZLACPY( 'All', M, N, C, MAXM, CC, MAXM)
|
||
|
|
CALL ZTRSYL( TRANA, TRANB, ISGN, M, N,
|
||
|
|
$ A, MAXM, B, MAXN, X, MAXM,
|
||
|
|
$ SCALE, IINFO )
|
||
|
|
IF( IINFO.NE.0 )
|
||
|
|
$ NINFO( 1 ) = NINFO( 1 ) + 1
|
||
|
|
XNRM = ZLANGE( 'M', M, N, X, MAXM, DUM )
|
||
|
|
RMUL = CONE
|
||
|
|
IF( XNRM.GT.ONE .AND. TNRM.GT.ONE ) THEN
|
||
|
|
IF( XNRM.GT.BIGNUM / TNRM ) THEN
|
||
|
|
RMUL = CONE / MAX( XNRM, TNRM )
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
CALL ZGEMM( TRANA, 'N', M, N, M, RMUL,
|
||
|
|
$ A, MAXM, X, MAXM, -SCALE*RMUL,
|
||
|
|
$ CC, MAXM )
|
||
|
|
CALL ZGEMM( 'N', TRANB, M, N, N,
|
||
|
|
$ DBLE( ISGN )*RMUL, X, MAXM, B,
|
||
|
|
$ MAXN, CONE, CC, MAXM )
|
||
|
|
RES1 = ZLANGE( 'M', M, N, CC, MAXM, DUM )
|
||
|
|
RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM,
|
||
|
|
$ ( ( ABS( RMUL )*TNRM )*EPS )*XNRM )
|
||
|
|
IF( RES.GT.THRESH )
|
||
|
|
$ NFAIL( 1 ) = NFAIL( 1 ) + 1
|
||
|
|
IF( RES.GT.RMAX( 1 ) )
|
||
|
|
$ RMAX( 1 ) = RES
|
||
|
|
*
|
||
|
|
CALL ZLACPY( 'All', M, N, C, MAXM, X, MAXM )
|
||
|
|
CALL ZLACPY( 'All', M, N, C, MAXM, CC, MAXM )
|
||
|
|
CALL ZTRSYL3( TRANA, TRANB, ISGN, M, N,
|
||
|
|
$ A, MAXM, B, MAXN, X, MAXM,
|
||
|
|
$ SCALE3, SWORK, LDSWORK, INFO)
|
||
|
|
IF( INFO.NE.0 )
|
||
|
|
$ NINFO( 2 ) = NINFO( 2 ) + 1
|
||
|
|
XNRM = ZLANGE( 'M', M, N, X, MAXM, DUM )
|
||
|
|
RMUL = CONE
|
||
|
|
IF( XNRM.GT.ONE .AND. TNRM.GT.ONE ) THEN
|
||
|
|
IF( XNRM.GT.BIGNUM / TNRM ) THEN
|
||
|
|
RMUL = CONE / MAX( XNRM, TNRM )
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
CALL ZGEMM( TRANA, 'N', M, N, M, RMUL,
|
||
|
|
$ A, MAXM, X, MAXM, -SCALE3*RMUL,
|
||
|
|
$ CC, MAXM )
|
||
|
|
CALL ZGEMM( 'N', TRANB, M, N, N,
|
||
|
|
$ DBLE( ISGN )*RMUL, X, MAXM, B,
|
||
|
|
$ MAXN, CONE, CC, MAXM )
|
||
|
|
RES1 = ZLANGE( 'M', M, N, CC, MAXM, DUM )
|
||
|
|
RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM,
|
||
|
|
$ ( ( ABS( RMUL )*TNRM )*EPS )*XNRM )
|
||
|
|
* Verify that TRSYL3 only flushes if TRSYL flushes (but
|
||
|
|
* there may be cases where TRSYL3 avoid flushing).
|
||
|
|
IF( SCALE3.EQ.ZERO .AND. SCALE.GT.ZERO .OR.
|
||
|
|
$ IINFO.NE.INFO ) THEN
|
||
|
|
NFAIL( 3 ) = NFAIL( 3 ) + 1
|
||
|
|
END IF
|
||
|
|
IF( RES.GT.THRESH .OR. DISNAN( RES ) )
|
||
|
|
$ NFAIL( 2 ) = NFAIL( 2 ) + 1
|
||
|
|
IF( RES.GT.RMAX( 2 ) )
|
||
|
|
$ RMAX( 2 ) = RES
|
||
|
|
END DO
|
||
|
|
END DO
|
||
|
|
END DO
|
||
|
|
END DO
|
||
|
|
END DO
|
||
|
|
END DO
|
||
|
|
*
|
||
|
|
DEALLOCATE (A, STAT = AllocateStatus)
|
||
|
|
DEALLOCATE (B, STAT = AllocateStatus)
|
||
|
|
DEALLOCATE (C, STAT = AllocateStatus)
|
||
|
|
DEALLOCATE (CC, STAT = AllocateStatus)
|
||
|
|
DEALLOCATE (X, STAT = AllocateStatus)
|
||
|
|
DEALLOCATE (SWORK, STAT = AllocateStatus)
|
||
|
|
*
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* End of ZSYL01
|
||
|
|
*
|
||
|
|
END
|