![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CCHKGK 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE CCHKGK( NIN, NOUT ) 00012 * 00013 * .. Scalar Arguments .. 00014 * INTEGER NIN, NOUT 00015 * .. 00016 * 00017 * 00018 *> \par Purpose: 00019 * ============= 00020 *> 00021 *> \verbatim 00022 *> 00023 *> CCHKGK tests CGGBAK, a routine for backward balancing of 00024 *> a matrix pair (A, B). 00025 *> \endverbatim 00026 * 00027 * Arguments: 00028 * ========== 00029 * 00030 *> \param[in] NIN 00031 *> \verbatim 00032 *> NIN is INTEGER 00033 *> The logical unit number for input. NIN > 0. 00034 *> \endverbatim 00035 *> 00036 *> \param[in] NOUT 00037 *> \verbatim 00038 *> NOUT is INTEGER 00039 *> The logical unit number for output. NOUT > 0. 00040 *> \endverbatim 00041 * 00042 * Authors: 00043 * ======== 00044 * 00045 *> \author Univ. of Tennessee 00046 *> \author Univ. of California Berkeley 00047 *> \author Univ. of Colorado Denver 00048 *> \author NAG Ltd. 00049 * 00050 *> \date November 2011 00051 * 00052 *> \ingroup complex_eig 00053 * 00054 * ===================================================================== 00055 SUBROUTINE CCHKGK( NIN, NOUT ) 00056 * 00057 * -- LAPACK test routine (version 3.4.0) -- 00058 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00059 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00060 * November 2011 00061 * 00062 * .. Scalar Arguments .. 00063 INTEGER NIN, NOUT 00064 * .. 00065 * 00066 * ===================================================================== 00067 * 00068 * .. Parameters .. 00069 INTEGER LDA, LDB, LDVL, LDVR 00070 PARAMETER ( LDA = 50, LDB = 50, LDVL = 50, LDVR = 50 ) 00071 INTEGER LDE, LDF, LDWORK, LRWORK 00072 PARAMETER ( LDE = 50, LDF = 50, LDWORK = 50, 00073 $ LRWORK = 6*50 ) 00074 REAL ZERO 00075 PARAMETER ( ZERO = 0.0E+0 ) 00076 COMPLEX CZERO, CONE 00077 PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), 00078 $ CONE = ( 1.0E+0, 0.0E+0 ) ) 00079 * .. 00080 * .. Local Scalars .. 00081 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO 00082 REAL ANORM, BNORM, EPS, RMAX, VMAX 00083 COMPLEX CDUM 00084 * .. 00085 * .. Local Arrays .. 00086 INTEGER LMAX( 4 ) 00087 REAL LSCALE( LDA ), RSCALE( LDA ), RWORK( LRWORK ) 00088 COMPLEX A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ), 00089 $ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ), 00090 $ VL( LDVL, LDVL ), VLF( LDVL, LDVL ), 00091 $ VR( LDVR, LDVR ), VRF( LDVR, LDVR ), 00092 $ WORK( LDWORK, LDWORK ) 00093 * .. 00094 * .. External Functions .. 00095 REAL CLANGE, SLAMCH 00096 EXTERNAL CLANGE, SLAMCH 00097 * .. 00098 * .. External Subroutines .. 00099 EXTERNAL CGEMM, CGGBAK, CGGBAL, CLACPY 00100 * .. 00101 * .. Intrinsic Functions .. 00102 INTRINSIC ABS, AIMAG, MAX, REAL 00103 * .. 00104 * .. Statement Functions .. 00105 REAL CABS1 00106 * .. 00107 * .. Statement Function definitions .. 00108 CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) 00109 * .. 00110 * .. Executable Statements .. 00111 * 00112 LMAX( 1 ) = 0 00113 LMAX( 2 ) = 0 00114 LMAX( 3 ) = 0 00115 LMAX( 4 ) = 0 00116 NINFO = 0 00117 KNT = 0 00118 RMAX = ZERO 00119 * 00120 EPS = SLAMCH( 'Precision' ) 00121 * 00122 10 CONTINUE 00123 READ( NIN, FMT = * )N, M 00124 IF( N.EQ.0 ) 00125 $ GO TO 100 00126 * 00127 DO 20 I = 1, N 00128 READ( NIN, FMT = * )( A( I, J ), J = 1, N ) 00129 20 CONTINUE 00130 * 00131 DO 30 I = 1, N 00132 READ( NIN, FMT = * )( B( I, J ), J = 1, N ) 00133 30 CONTINUE 00134 * 00135 DO 40 I = 1, N 00136 READ( NIN, FMT = * )( VL( I, J ), J = 1, M ) 00137 40 CONTINUE 00138 * 00139 DO 50 I = 1, N 00140 READ( NIN, FMT = * )( VR( I, J ), J = 1, M ) 00141 50 CONTINUE 00142 * 00143 KNT = KNT + 1 00144 * 00145 ANORM = CLANGE( 'M', N, N, A, LDA, RWORK ) 00146 BNORM = CLANGE( 'M', N, N, B, LDB, RWORK ) 00147 * 00148 CALL CLACPY( 'FULL', N, N, A, LDA, AF, LDA ) 00149 CALL CLACPY( 'FULL', N, N, B, LDB, BF, LDB ) 00150 * 00151 CALL CGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, 00152 $ RWORK, INFO ) 00153 IF( INFO.NE.0 ) THEN 00154 NINFO = NINFO + 1 00155 LMAX( 1 ) = KNT 00156 END IF 00157 * 00158 CALL CLACPY( 'FULL', N, M, VL, LDVL, VLF, LDVL ) 00159 CALL CLACPY( 'FULL', N, M, VR, LDVR, VRF, LDVR ) 00160 * 00161 CALL CGGBAK( 'B', 'L', N, ILO, IHI, LSCALE, RSCALE, M, VL, LDVL, 00162 $ INFO ) 00163 IF( INFO.NE.0 ) THEN 00164 NINFO = NINFO + 1 00165 LMAX( 2 ) = KNT 00166 END IF 00167 * 00168 CALL CGGBAK( 'B', 'R', N, ILO, IHI, LSCALE, RSCALE, M, VR, LDVR, 00169 $ INFO ) 00170 IF( INFO.NE.0 ) THEN 00171 NINFO = NINFO + 1 00172 LMAX( 3 ) = KNT 00173 END IF 00174 * 00175 * Test of CGGBAK 00176 * 00177 * Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR 00178 * where tilde(A) denotes the transformed matrix. 00179 * 00180 CALL CGEMM( 'N', 'N', N, M, N, CONE, AF, LDA, VR, LDVR, CZERO, 00181 $ WORK, LDWORK ) 00182 CALL CGEMM( 'C', 'N', M, M, N, CONE, VL, LDVL, WORK, LDWORK, 00183 $ CZERO, E, LDE ) 00184 * 00185 CALL CGEMM( 'N', 'N', N, M, N, CONE, A, LDA, VRF, LDVR, CZERO, 00186 $ WORK, LDWORK ) 00187 CALL CGEMM( 'C', 'N', M, M, N, CONE, VLF, LDVL, WORK, LDWORK, 00188 $ CZERO, F, LDF ) 00189 * 00190 VMAX = ZERO 00191 DO 70 J = 1, M 00192 DO 60 I = 1, M 00193 VMAX = MAX( VMAX, CABS1( E( I, J )-F( I, J ) ) ) 00194 60 CONTINUE 00195 70 CONTINUE 00196 VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) ) 00197 IF( VMAX.GT.RMAX ) THEN 00198 LMAX( 4 ) = KNT 00199 RMAX = VMAX 00200 END IF 00201 * 00202 * Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR 00203 * 00204 CALL CGEMM( 'N', 'N', N, M, N, CONE, BF, LDB, VR, LDVR, CZERO, 00205 $ WORK, LDWORK ) 00206 CALL CGEMM( 'C', 'N', M, M, N, CONE, VL, LDVL, WORK, LDWORK, 00207 $ CZERO, E, LDE ) 00208 * 00209 CALL CGEMM( 'n', 'n', N, M, N, CONE, B, LDB, VRF, LDVR, CZERO, 00210 $ WORK, LDWORK ) 00211 CALL CGEMM( 'C', 'N', M, M, N, CONE, VLF, LDVL, WORK, LDWORK, 00212 $ CZERO, F, LDF ) 00213 * 00214 VMAX = ZERO 00215 DO 90 J = 1, M 00216 DO 80 I = 1, M 00217 VMAX = MAX( VMAX, CABS1( E( I, J )-F( I, J ) ) ) 00218 80 CONTINUE 00219 90 CONTINUE 00220 VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) ) 00221 IF( VMAX.GT.RMAX ) THEN 00222 LMAX( 4 ) = KNT 00223 RMAX = VMAX 00224 END IF 00225 * 00226 GO TO 10 00227 * 00228 100 CONTINUE 00229 * 00230 WRITE( NOUT, FMT = 9999 ) 00231 9999 FORMAT( 1X, '.. test output of CGGBAK .. ' ) 00232 * 00233 WRITE( NOUT, FMT = 9998 )RMAX 00234 9998 FORMAT( ' value of largest test error =', E12.3 ) 00235 WRITE( NOUT, FMT = 9997 )LMAX( 1 ) 00236 9997 FORMAT( ' example number where CGGBAL info is not 0 =', I4 ) 00237 WRITE( NOUT, FMT = 9996 )LMAX( 2 ) 00238 9996 FORMAT( ' example number where CGGBAK(L) info is not 0 =', I4 ) 00239 WRITE( NOUT, FMT = 9995 )LMAX( 3 ) 00240 9995 FORMAT( ' example number where CGGBAK(R) info is not 0 =', I4 ) 00241 WRITE( NOUT, FMT = 9994 )LMAX( 4 ) 00242 9994 FORMAT( ' example number having largest error =', I4 ) 00243 WRITE( NOUT, FMT = 9992 )NINFO 00244 9992 FORMAT( ' number of examples where info is not 0 =', I4 ) 00245 WRITE( NOUT, FMT = 9991 )KNT 00246 9991 FORMAT( ' total number of examples tested =', I4 ) 00247 * 00248 RETURN 00249 * 00250 * End of CCHKGK 00251 * 00252 END