![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCKCSD 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 SCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, 00012 * MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, 00013 * WORK, RWORK, NIN, NOUT, INFO ) 00014 * 00015 * .. Scalar Arguments .. 00016 * INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT 00017 * REAL THRESH 00018 * .. 00019 * .. Array Arguments .. 00020 * INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ), 00021 * $ QVAL( * ) 00022 * REAL RWORK( * ), THETA( * ) 00023 * REAL U1( * ), U2( * ), V1T( * ), V2T( * ), 00024 * $ WORK( * ), X( * ), XF( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> SCKCSD tests SORCSD: 00034 *> the CSD for an M-by-M orthogonal matrix X partitioned as 00035 *> [ X11 X12; X21 X22 ]. X11 is P-by-Q. 00036 *> \endverbatim 00037 * 00038 * Arguments: 00039 * ========== 00040 * 00041 *> \param[in] NM 00042 *> \verbatim 00043 *> NM is INTEGER 00044 *> The number of values of M contained in the vector MVAL. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] MVAL 00048 *> \verbatim 00049 *> MVAL is INTEGER array, dimension (NM) 00050 *> The values of the matrix row dimension M. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] PVAL 00054 *> \verbatim 00055 *> PVAL is INTEGER array, dimension (NM) 00056 *> The values of the matrix row dimension P. 00057 *> \endverbatim 00058 *> 00059 *> \param[in] QVAL 00060 *> \verbatim 00061 *> QVAL is INTEGER array, dimension (NM) 00062 *> The values of the matrix column dimension Q. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] NMATS 00066 *> \verbatim 00067 *> NMATS is INTEGER 00068 *> The number of matrix types to be tested for each combination 00069 *> of matrix dimensions. If NMATS >= NTYPES (the maximum 00070 *> number of matrix types), then all the different types are 00071 *> generated for testing. If NMATS < NTYPES, another input line 00072 *> is read to get the numbers of the matrix types to be used. 00073 *> \endverbatim 00074 *> 00075 *> \param[in,out] ISEED 00076 *> \verbatim 00077 *> ISEED is INTEGER array, dimension (4) 00078 *> On entry, the seed of the random number generator. The array 00079 *> elements should be between 0 and 4095, otherwise they will be 00080 *> reduced mod 4096, and ISEED(4) must be odd. 00081 *> On exit, the next seed in the random number sequence after 00082 *> all the test matrices have been generated. 00083 *> \endverbatim 00084 *> 00085 *> \param[in] THRESH 00086 *> \verbatim 00087 *> THRESH is REAL 00088 *> The threshold value for the test ratios. A result is 00089 *> included in the output file if RESULT >= THRESH. To have 00090 *> every test ratio printed, use THRESH = 0. 00091 *> \endverbatim 00092 *> 00093 *> \param[in] MMAX 00094 *> \verbatim 00095 *> MMAX is INTEGER 00096 *> The maximum value permitted for M, used in dimensioning the 00097 *> work arrays. 00098 *> \endverbatim 00099 *> 00100 *> \param[out] X 00101 *> \verbatim 00102 *> X is REAL array, dimension (MMAX*MMAX) 00103 *> \endverbatim 00104 *> 00105 *> \param[out] XF 00106 *> \verbatim 00107 *> XF is REAL array, dimension (MMAX*MMAX) 00108 *> \endverbatim 00109 *> 00110 *> \param[out] U1 00111 *> \verbatim 00112 *> U1 is REAL array, dimension (MMAX*MMAX) 00113 *> \endverbatim 00114 *> 00115 *> \param[out] U2 00116 *> \verbatim 00117 *> U2 is REAL array, dimension (MMAX*MMAX) 00118 *> \endverbatim 00119 *> 00120 *> \param[out] V1T 00121 *> \verbatim 00122 *> V1T is REAL array, dimension (MMAX*MMAX) 00123 *> \endverbatim 00124 *> 00125 *> \param[out] V2T 00126 *> \verbatim 00127 *> V2T is REAL array, dimension (MMAX*MMAX) 00128 *> \endverbatim 00129 *> 00130 *> \param[out] THETA 00131 *> \verbatim 00132 *> THETA is REAL array, dimension (MMAX) 00133 *> \endverbatim 00134 *> 00135 *> \param[out] IWORK 00136 *> \verbatim 00137 *> IWORK is INTEGER array, dimension (MMAX) 00138 *> \endverbatim 00139 *> 00140 *> \param[out] WORK 00141 *> \verbatim 00142 *> WORK is REAL array 00143 *> \endverbatim 00144 *> 00145 *> \param[out] RWORK 00146 *> \verbatim 00147 *> RWORK is REAL array 00148 *> \endverbatim 00149 *> 00150 *> \param[in] NIN 00151 *> \verbatim 00152 *> NIN is INTEGER 00153 *> The unit number for input. 00154 *> \endverbatim 00155 *> 00156 *> \param[in] NOUT 00157 *> \verbatim 00158 *> NOUT is INTEGER 00159 *> The unit number for output. 00160 *> \endverbatim 00161 *> 00162 *> \param[out] INFO 00163 *> \verbatim 00164 *> INFO is INTEGER 00165 *> = 0 : successful exit 00166 *> > 0 : If SLAROR returns an error code, the absolute value 00167 *> of it is returned. 00168 *> \endverbatim 00169 * 00170 * Authors: 00171 * ======== 00172 * 00173 *> \author Univ. of Tennessee 00174 *> \author Univ. of California Berkeley 00175 *> \author Univ. of Colorado Denver 00176 *> \author NAG Ltd. 00177 * 00178 *> \date November 2011 00179 * 00180 *> \ingroup single_eig 00181 * 00182 * ===================================================================== 00183 SUBROUTINE SCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, 00184 $ MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, 00185 $ WORK, RWORK, NIN, NOUT, INFO ) 00186 * 00187 * -- LAPACK test routine (version 3.4.0) -- 00188 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00189 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00190 * November 2011 00191 * 00192 * .. Scalar Arguments .. 00193 INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT 00194 REAL THRESH 00195 * .. 00196 * .. Array Arguments .. 00197 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ), 00198 $ QVAL( * ) 00199 REAL RWORK( * ), THETA( * ) 00200 REAL U1( * ), U2( * ), V1T( * ), V2T( * ), 00201 $ WORK( * ), X( * ), XF( * ) 00202 * .. 00203 * 00204 * ===================================================================== 00205 * 00206 * .. Parameters .. 00207 INTEGER NTESTS 00208 PARAMETER ( NTESTS = 9 ) 00209 INTEGER NTYPES 00210 PARAMETER ( NTYPES = 3 ) 00211 REAL GAPDIGIT, ORTH, PIOVER2, TEN 00212 PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4, 00213 $ PIOVER2 = 1.57079632679489662E0, 00214 $ TEN = 10.0D0 ) 00215 * .. 00216 * .. Local Scalars .. 00217 LOGICAL FIRSTT 00218 CHARACTER*3 PATH 00219 INTEGER I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T, 00220 $ LDV2T, LDX, LWORK, M, NFAIL, NRUN, NT, P, Q, R 00221 * .. 00222 * .. Local Arrays .. 00223 LOGICAL DOTYPE( NTYPES ) 00224 REAL RESULT( NTESTS ) 00225 * .. 00226 * .. External Subroutines .. 00227 EXTERNAL ALAHDG, ALAREQ, ALASUM, SCSDTS, SLACSG, SLAROR, 00228 $ SLASET 00229 * .. 00230 * .. Intrinsic Functions .. 00231 INTRINSIC ABS, MIN 00232 * .. 00233 * .. External Functions .. 00234 REAL SLARND 00235 EXTERNAL SLARND 00236 * .. 00237 * .. Executable Statements .. 00238 * 00239 * Initialize constants and the random number seed. 00240 * 00241 PATH( 1: 3 ) = 'CSD' 00242 INFO = 0 00243 NRUN = 0 00244 NFAIL = 0 00245 FIRSTT = .TRUE. 00246 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) 00247 LDX = MMAX 00248 LDU1 = MMAX 00249 LDU2 = MMAX 00250 LDV1T = MMAX 00251 LDV2T = MMAX 00252 LWORK = MMAX*MMAX 00253 * 00254 * Do for each value of M in MVAL. 00255 * 00256 DO 30 IM = 1, NM 00257 M = MVAL( IM ) 00258 P = PVAL( IM ) 00259 Q = QVAL( IM ) 00260 * 00261 DO 20 IMAT = 1, NTYPES 00262 * 00263 * Do the tests only if DOTYPE( IMAT ) is true. 00264 * 00265 IF( .NOT.DOTYPE( IMAT ) ) 00266 $ GO TO 20 00267 * 00268 * Generate X 00269 * 00270 IF( IMAT.EQ.1 ) THEN 00271 CALL SLAROR( 'L', 'I', M, M, X, LDX, ISEED, WORK, IINFO ) 00272 IF( M .NE. 0 .AND. IINFO .NE. 0 ) THEN 00273 WRITE( NOUT, FMT = 9999 ) M, IINFO 00274 INFO = ABS( IINFO ) 00275 GO TO 20 00276 END IF 00277 ELSE IF( IMAT.EQ.2 ) THEN 00278 R = MIN( P, M-P, Q, M-Q ) 00279 DO I = 1, R 00280 THETA(I) = PIOVER2 * SLARND( 1, ISEED ) 00281 END DO 00282 CALL SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) 00283 DO I = 1, M 00284 DO J = 1, M 00285 X(I+(J-1)*LDX) = X(I+(J-1)*LDX) + 00286 $ ORTH*SLARND(2,ISEED) 00287 END DO 00288 END DO 00289 ELSE 00290 R = MIN( P, M-P, Q, M-Q ) 00291 DO I = 1, R+1 00292 THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT) 00293 END DO 00294 DO I = 2, R+1 00295 THETA(I) = THETA(I-1) + THETA(I) 00296 END DO 00297 DO I = 1, R 00298 THETA(I) = PIOVER2 * THETA(I) / THETA(R+1) 00299 END DO 00300 CALL SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) 00301 END IF 00302 * 00303 NT = 9 00304 * 00305 CALL SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, 00306 $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, 00307 $ RWORK, RESULT ) 00308 * 00309 * Print information about the tests that did not 00310 * pass the threshold. 00311 * 00312 DO 10 I = 1, NT 00313 IF( RESULT( I ).GE.THRESH ) THEN 00314 IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN 00315 FIRSTT = .FALSE. 00316 CALL ALAHDG( NOUT, PATH ) 00317 END IF 00318 WRITE( NOUT, FMT = 9998 )M, P, Q, IMAT, I, 00319 $ RESULT( I ) 00320 NFAIL = NFAIL + 1 00321 END IF 00322 10 CONTINUE 00323 NRUN = NRUN + NT 00324 20 CONTINUE 00325 30 CONTINUE 00326 * 00327 * Print a summary of the results. 00328 * 00329 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 ) 00330 * 00331 9999 FORMAT( ' SLAROR in SCKCSD: M = ', I5, ', INFO = ', I15 ) 00332 9998 FORMAT( ' M=', I4, ' P=', I4, ', Q=', I4, ', type ', I2, 00333 $ ', test ', I2, ', ratio=', G13.6 ) 00334 RETURN 00335 * 00336 * End of SCKCSD 00337 * 00338 END 00339 * 00340 * 00341 * 00342 SUBROUTINE SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) 00343 IMPLICIT NONE 00344 * 00345 INTEGER LDX, M, P, Q 00346 INTEGER ISEED( 4 ) 00347 REAL THETA( * ) 00348 REAL WORK( * ), X( LDX, * ) 00349 * 00350 REAL ONE, ZERO 00351 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) 00352 * 00353 INTEGER I, INFO, R 00354 * 00355 R = MIN( P, M-P, Q, M-Q ) 00356 * 00357 CALL SLASET( 'Full', M, M, ZERO, ZERO, X, LDX ) 00358 * 00359 DO I = 1, MIN(P,Q)-R 00360 X(I,I) = ONE 00361 END DO 00362 DO I = 1, R 00363 X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = COS(THETA(I)) 00364 END DO 00365 DO I = 1, MIN(P,M-Q)-R 00366 X(P-I+1,M-I+1) = -ONE 00367 END DO 00368 DO I = 1, R 00369 X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = 00370 $ -SIN(THETA(R-I+1)) 00371 END DO 00372 DO I = 1, MIN(M-P,Q)-R 00373 X(M-I+1,Q-I+1) = ONE 00374 END DO 00375 DO I = 1, R 00376 X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = 00377 $ SIN(THETA(R-I+1)) 00378 END DO 00379 DO I = 1, MIN(M-P,M-Q)-R 00380 X(P+I,Q+I) = ONE 00381 END DO 00382 DO I = 1, R 00383 X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = 00384 $ COS(THETA(I)) 00385 END DO 00386 CALL SLAROR( 'Left', 'No init', P, M, X, LDX, ISEED, WORK, INFO ) 00387 CALL SLAROR( 'Left', 'No init', M-P, M, X(P+1,1), LDX, 00388 $ ISEED, WORK, INFO ) 00389 CALL SLAROR( 'Right', 'No init', M, Q, X, LDX, ISEED, 00390 $ WORK, INFO ) 00391 CALL SLAROR( 'Right', 'No init', M, M-Q, 00392 $ X(1,Q+1), LDX, ISEED, WORK, INFO ) 00393 * 00394 END 00395