 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, 00002 $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, 00003 $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, 00004 $ PACK, A, LDA, IWORK, INFO ) 00005 * 00006 * -- LAPACK test routine (version 3.1) -- 00007 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00008 * June 2010 00009 * 00010 * .. Scalar Arguments .. 00011 CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM 00012 INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N 00013 REAL ANORM, COND, CONDL, CONDR, SPARSE 00014 COMPLEX DMAX 00015 * .. 00016 * .. Array Arguments .. 00017 INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) 00018 COMPLEX A( LDA, * ), D( * ), DL( * ), DR( * ) 00019 * .. 00020 * 00021 * Purpose 00022 * ======= 00023 * 00024 * CLATMR generates random matrices of various types for testing 00025 * LAPACK programs. 00026 * 00027 * CLATMR operates by applying the following sequence of 00028 * operations: 00029 * 00030 * Generate a matrix A with random entries of distribution DIST 00031 * which is symmetric if SYM='S', Hermitian if SYM='H', and 00032 * nonsymmetric if SYM='N'. 00033 * 00034 * Set the diagonal to D, where D may be input or 00035 * computed according to MODE, COND, DMAX and RSIGN 00036 * as described below. 00037 * 00038 * Grade the matrix, if desired, from the left and/or right 00039 * as specified by GRADE. The inputs DL, MODEL, CONDL, DR, 00040 * MODER and CONDR also determine the grading as described 00041 * below. 00042 * 00043 * Permute, if desired, the rows and/or columns as specified by 00044 * PIVTNG and IPIVOT. 00045 * 00046 * Set random entries to zero, if desired, to get a random sparse 00047 * matrix as specified by SPARSE. 00048 * 00049 * Make A a band matrix, if desired, by zeroing out the matrix 00050 * outside a band of lower bandwidth KL and upper bandwidth KU. 00051 * 00052 * Scale A, if desired, to have maximum entry ANORM. 00053 * 00054 * Pack the matrix if desired. Options specified by PACK are: 00055 * no packing 00056 * zero out upper half (if symmetric or Hermitian) 00057 * zero out lower half (if symmetric or Hermitian) 00058 * store the upper half columnwise (if symmetric or Hermitian 00059 * or square upper triangular) 00060 * store the lower half columnwise (if symmetric or Hermitian 00061 * or square lower triangular) 00062 * same as upper half rowwise if symmetric 00063 * same as conjugate upper half rowwise if Hermitian 00064 * store the lower triangle in banded format 00065 * (if symmetric or Hermitian) 00066 * store the upper triangle in banded format 00067 * (if symmetric or Hermitian) 00068 * store the entire matrix in banded format 00069 * 00070 * Note: If two calls to CLATMR differ only in the PACK parameter, 00071 * they will generate mathematically equivalent matrices. 00072 * 00073 * If two calls to CLATMR both have full bandwidth (KL = M-1 00074 * and KU = N-1), and differ only in the PIVTNG and PACK 00075 * parameters, then the matrices generated will differ only 00076 * in the order of the rows and/or columns, and otherwise 00077 * contain the same data. This consistency cannot be and 00078 * is not maintained with less than full bandwidth. 00079 * 00080 * Arguments 00081 * ========= 00082 * 00083 * M (input) INTEGER 00084 * Number of rows of A. Not modified. 00085 * 00086 * N (input) INTEGER 00087 * Number of columns of A. Not modified. 00088 * 00089 * DIST (input) CHARACTER*1 00090 * On entry, DIST specifies the type of distribution to be used 00091 * to generate a random matrix . 00092 * 'U' => real and imaginary parts are independent 00093 * UNIFORM( 0, 1 ) ( 'U' for uniform ) 00094 * 'S' => real and imaginary parts are independent 00095 * UNIFORM( -1, 1 ) ( 'S' for symmetric ) 00096 * 'N' => real and imaginary parts are independent 00097 * NORMAL( 0, 1 ) ( 'N' for normal ) 00098 * 'D' => uniform on interior of unit disk ( 'D' for disk ) 00099 * Not modified. 00100 * 00101 * ISEED (input/output) INTEGER array, dimension (4) 00102 * On entry ISEED specifies the seed of the random number 00103 * generator. They should lie between 0 and 4095 inclusive, 00104 * and ISEED(4) should be odd. The random number generator 00105 * uses a linear congruential sequence limited to small 00106 * integers, and so should produce machine independent 00107 * random numbers. The values of ISEED are changed on 00108 * exit, and can be used in the next call to CLATMR 00109 * to continue the same random number sequence. 00110 * Changed on exit. 00111 * 00112 * SYM (input) CHARACTER*1 00113 * If SYM='S', generated matrix is symmetric. 00114 * If SYM='H', generated matrix is Hermitian. 00115 * If SYM='N', generated matrix is nonsymmetric. 00116 * Not modified. 00117 * 00118 * D (input/output) COMPLEX array, dimension (min(M,N)) 00119 * On entry this array specifies the diagonal entries 00120 * of the diagonal of A. D may either be specified 00121 * on entry, or set according to MODE and COND as described 00122 * below. If the matrix is Hermitian, the real part of D 00123 * will be taken. May be changed on exit if MODE is nonzero. 00124 * 00125 * MODE (input) INTEGER 00126 * On entry describes how D is to be used: 00127 * MODE = 0 means use D as input 00128 * MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND 00129 * MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND 00130 * MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) 00131 * MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) 00132 * MODE = 5 sets D to random numbers in the range 00133 * ( 1/COND , 1 ) such that their logarithms 00134 * are uniformly distributed. 00135 * MODE = 6 set D to random numbers from same distribution 00136 * as the rest of the matrix. 00137 * MODE < 0 has the same meaning as ABS(MODE), except that 00138 * the order of the elements of D is reversed. 00139 * Thus if MODE is positive, D has entries ranging from 00140 * 1 to 1/COND, if negative, from 1/COND to 1, 00141 * Not modified. 00142 * 00143 * COND (input) REAL 00144 * On entry, used as described under MODE above. 00145 * If used, it must be >= 1. Not modified. 00146 * 00147 * DMAX (input) COMPLEX 00148 * If MODE neither -6, 0 nor 6, the diagonal is scaled by 00149 * DMAX / max(abs(D(i))), so that maximum absolute entry 00150 * of diagonal is abs(DMAX). If DMAX is complex (or zero), 00151 * diagonal will be scaled by a complex number (or zero). 00152 * 00153 * RSIGN (input) CHARACTER*1 00154 * If MODE neither -6, 0 nor 6, specifies sign of diagonal 00155 * as follows: 00156 * 'T' => diagonal entries are multiplied by a random complex 00157 * number uniformly distributed with absolute value 1 00158 * 'F' => diagonal unchanged 00159 * Not modified. 00160 * 00161 * GRADE (input) CHARACTER*1 00162 * Specifies grading of matrix as follows: 00163 * 'N' => no grading 00164 * 'L' => matrix premultiplied by diag( DL ) 00165 * (only if matrix nonsymmetric) 00166 * 'R' => matrix postmultiplied by diag( DR ) 00167 * (only if matrix nonsymmetric) 00168 * 'B' => matrix premultiplied by diag( DL ) and 00169 * postmultiplied by diag( DR ) 00170 * (only if matrix nonsymmetric) 00171 * 'H' => matrix premultiplied by diag( DL ) and 00172 * postmultiplied by diag( CONJG(DL) ) 00173 * (only if matrix Hermitian or nonsymmetric) 00174 * 'S' => matrix premultiplied by diag( DL ) and 00175 * postmultiplied by diag( DL ) 00176 * (only if matrix symmetric or nonsymmetric) 00177 * 'E' => matrix premultiplied by diag( DL ) and 00178 * postmultiplied by inv( diag( DL ) ) 00179 * ( 'S' for similarity ) 00180 * (only if matrix nonsymmetric) 00181 * Note: if GRADE='S', then M must equal N. 00182 * Not modified. 00183 * 00184 * DL (input/output) COMPLEX array, dimension (M) 00185 * If MODEL=0, then on entry this array specifies the diagonal 00186 * entries of a diagonal matrix used as described under GRADE 00187 * above. If MODEL is not zero, then DL will be set according 00188 * to MODEL and CONDL, analogous to the way D is set according 00189 * to MODE and COND (except there is no DMAX parameter for DL). 00190 * If GRADE='E', then DL cannot have zero entries. 00191 * Not referenced if GRADE = 'N' or 'R'. Changed on exit. 00192 * 00193 * MODEL (input) INTEGER 00194 * This specifies how the diagonal array DL is to be computed, 00195 * just as MODE specifies how D is to be computed. 00196 * Not modified. 00197 * 00198 * CONDL (input) REAL 00199 * When MODEL is not zero, this specifies the condition number 00200 * of the computed DL. Not modified. 00201 * 00202 * DR (input/output) COMPLEX array, dimension (N) 00203 * If MODER=0, then on entry this array specifies the diagonal 00204 * entries of a diagonal matrix used as described under GRADE 00205 * above. If MODER is not zero, then DR will be set according 00206 * to MODER and CONDR, analogous to the way D is set according 00207 * to MODE and COND (except there is no DMAX parameter for DR). 00208 * Not referenced if GRADE = 'N', 'L', 'H' or 'S'. 00209 * Changed on exit. 00210 * 00211 * MODER (input) INTEGER 00212 * This specifies how the diagonal array DR is to be computed, 00213 * just as MODE specifies how D is to be computed. 00214 * Not modified. 00215 * 00216 * CONDR (input) REAL 00217 * When MODER is not zero, this specifies the condition number 00218 * of the computed DR. Not modified. 00219 * 00220 * PIVTNG (input) CHARACTER*1 00221 * On entry specifies pivoting permutations as follows: 00222 * 'N' or ' ' => none. 00223 * 'L' => left or row pivoting (matrix must be nonsymmetric). 00224 * 'R' => right or column pivoting (matrix must be 00225 * nonsymmetric). 00226 * 'B' or 'F' => both or full pivoting, i.e., on both sides. 00227 * In this case, M must equal N 00228 * 00229 * If two calls to CLATMR both have full bandwidth (KL = M-1 00230 * and KU = N-1), and differ only in the PIVTNG and PACK 00231 * parameters, then the matrices generated will differ only 00232 * in the order of the rows and/or columns, and otherwise 00233 * contain the same data. This consistency cannot be 00234 * maintained with less than full bandwidth. 00235 * 00236 * IPIVOT (input) INTEGER array, dimension (N or M) 00237 * This array specifies the permutation used. After the 00238 * basic matrix is generated, the rows, columns, or both 00239 * are permuted. If, say, row pivoting is selected, CLATMR 00240 * starts with the *last* row and interchanges the M-th and 00241 * IPIVOT(M)-th rows, then moves to the next-to-last row, 00242 * interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, 00243 * and so on. In terms of "2-cycles", the permutation is 00244 * (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) 00245 * where the rightmost cycle is applied first. This is the 00246 * *inverse* of the effect of pivoting in LINPACK. The idea 00247 * is that factoring (with pivoting) an identity matrix 00248 * which has been inverse-pivoted in this way should 00249 * result in a pivot vector identical to IPIVOT. 00250 * Not referenced if PIVTNG = 'N'. Not modified. 00251 * 00252 * SPARSE (input) REAL 00253 * On entry specifies the sparsity of the matrix if a sparse 00254 * matrix is to be generated. SPARSE should lie between 00255 * 0 and 1. To generate a sparse matrix, for each matrix entry 00256 * a uniform ( 0, 1 ) random number x is generated and 00257 * compared to SPARSE; if x is larger the matrix entry 00258 * is unchanged and if x is smaller the entry is set 00259 * to zero. Thus on the average a fraction SPARSE of the 00260 * entries will be set to zero. 00261 * Not modified. 00262 * 00263 * KL (input) INTEGER 00264 * On entry specifies the lower bandwidth of the matrix. For 00265 * example, KL=0 implies upper triangular, KL=1 implies upper 00266 * Hessenberg, and KL at least M-1 implies the matrix is not 00267 * banded. Must equal KU if matrix is symmetric or Hermitian. 00268 * Not modified. 00269 * 00270 * KU (input) INTEGER 00271 * On entry specifies the upper bandwidth of the matrix. For 00272 * example, KU=0 implies lower triangular, KU=1 implies lower 00273 * Hessenberg, and KU at least N-1 implies the matrix is not 00274 * banded. Must equal KL if matrix is symmetric or Hermitian. 00275 * Not modified. 00276 * 00277 * ANORM (input) REAL 00278 * On entry specifies maximum entry of output matrix 00279 * (output matrix will by multiplied by a constant so that 00280 * its largest absolute entry equal ANORM) 00281 * if ANORM is nonnegative. If ANORM is negative no scaling 00282 * is done. Not modified. 00283 * 00284 * PACK (input) CHARACTER*1 00285 * On entry specifies packing of matrix as follows: 00286 * 'N' => no packing 00287 * 'U' => zero out all subdiagonal entries 00288 * (if symmetric or Hermitian) 00289 * 'L' => zero out all superdiagonal entries 00290 * (if symmetric or Hermitian) 00291 * 'C' => store the upper triangle columnwise 00292 * (only if matrix symmetric or Hermitian or 00293 * square upper triangular) 00294 * 'R' => store the lower triangle columnwise 00295 * (only if matrix symmetric or Hermitian or 00296 * square lower triangular) 00297 * (same as upper half rowwise if symmetric) 00298 * (same as conjugate upper half rowwise if Hermitian) 00299 * 'B' => store the lower triangle in band storage scheme 00300 * (only if matrix symmetric or Hermitian) 00301 * 'Q' => store the upper triangle in band storage scheme 00302 * (only if matrix symmetric or Hermitian) 00303 * 'Z' => store the entire matrix in band storage scheme 00304 * (pivoting can be provided for by using this 00305 * option to store A in the trailing rows of 00306 * the allocated storage) 00307 * 00308 * Using these options, the various LAPACK packed and banded 00309 * storage schemes can be obtained: 00310 * GB - use 'Z' 00311 * PB, HB or TB - use 'B' or 'Q' 00312 * PP, HP or TP - use 'C' or 'R' 00313 * 00314 * If two calls to CLATMR differ only in the PACK parameter, 00315 * they will generate mathematically equivalent matrices. 00316 * Not modified. 00317 * 00318 * A (input/output) COMPLEX array, dimension (LDA,N) 00319 * On exit A is the desired test matrix. Only those 00320 * entries of A which are significant on output 00321 * will be referenced (even if A is in packed or band 00322 * storage format). The 'unoccupied corners' of A in 00323 * band format will be zeroed out. 00324 * 00325 * LDA (input) INTEGER 00326 * on entry LDA specifies the first dimension of A as 00327 * declared in the calling program. 00328 * If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). 00329 * If PACK='C' or 'R', LDA must be at least 1. 00330 * If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) 00331 * If PACK='Z', LDA must be at least KUU+KLL+1, where 00332 * KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) 00333 * Not modified. 00334 * 00335 * IWORK (workspace) INTEGER array, dimension (N or M) 00336 * Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. 00337 * 00338 * INFO (output) INTEGER 00339 * Error parameter on exit: 00340 * 0 => normal return 00341 * -1 => M negative or unequal to N and SYM='S' or 'H' 00342 * -2 => N negative 00343 * -3 => DIST illegal string 00344 * -5 => SYM illegal string 00345 * -7 => MODE not in range -6 to 6 00346 * -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 00347 * -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string 00348 * -11 => GRADE illegal string, or GRADE='E' and 00349 * M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' 00350 * and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' 00351 * and SYM = 'S' 00352 * -12 => GRADE = 'E' and DL contains zero 00353 * -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', 00354 * 'S' or 'E' 00355 * -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', 00356 * and MODEL neither -6, 0 nor 6 00357 * -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' 00358 * -17 => CONDR less than 1.0, GRADE='R' or 'B', and 00359 * MODER neither -6, 0 nor 6 00360 * -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and 00361 * M not equal to N, or PIVTNG='L' or 'R' and SYM='S' 00362 * or 'H' 00363 * -19 => IPIVOT contains out of range number and 00364 * PIVTNG not equal to 'N' 00365 * -20 => KL negative 00366 * -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL 00367 * -22 => SPARSE not in range 0. to 1. 00368 * -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' 00369 * and SYM='N', or PACK='C' and SYM='N' and either KL 00370 * not equal to 0 or N not equal to M, or PACK='R' and 00371 * SYM='N', and either KU not equal to 0 or N not equal 00372 * to M 00373 * -26 => LDA too small 00374 * 1 => Error return from CLATM1 (computing D) 00375 * 2 => Cannot scale diagonal to DMAX (max. entry is 0) 00376 * 3 => Error return from CLATM1 (computing DL) 00377 * 4 => Error return from CLATM1 (computing DR) 00378 * 5 => ANORM is positive, but matrix constructed prior to 00379 * attempting to scale it to have norm ANORM, is zero 00380 * 00381 * ===================================================================== 00382 * 00383 * .. Parameters .. 00384 REAL ZERO 00385 PARAMETER ( ZERO = 0.0E0 ) 00386 REAL ONE 00387 PARAMETER ( ONE = 1.0E0 ) 00388 COMPLEX CONE 00389 PARAMETER ( CONE = ( 1.0E0, 0.0E0 ) ) 00390 COMPLEX CZERO 00391 PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ) ) 00392 * .. 00393 * .. Local Scalars .. 00394 LOGICAL BADPVT, DZERO, FULBND 00395 INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, 00396 $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, 00397 $ MNSUB, MXSUB, NPVTS 00398 REAL ONORM, TEMP 00399 COMPLEX CALPHA, CTEMP 00400 * .. 00401 * .. Local Arrays .. 00402 REAL TEMPA( 1 ) 00403 * .. 00404 * .. External Functions .. 00405 LOGICAL LSAME 00406 REAL CLANGB, CLANGE, CLANSB, CLANSP, CLANSY 00407 COMPLEX CLATM2, CLATM3 00408 EXTERNAL LSAME, CLANGB, CLANGE, CLANSB, CLANSP, CLANSY, 00409 $ CLATM2, CLATM3 00410 * .. 00411 * .. External Subroutines .. 00412 EXTERNAL CLATM1, CSSCAL, XERBLA 00413 * .. 00414 * .. Intrinsic Functions .. 00415 INTRINSIC ABS, CONJG, MAX, MIN, MOD, REAL 00416 * .. 00417 * .. Executable Statements .. 00418 * 00419 * 1) Decode and Test the input parameters. 00420 * Initialize flags & seed. 00421 * 00422 INFO = 0 00423 * 00424 * Quick return if possible 00425 * 00426 IF( M.EQ.0 .OR. N.EQ.0 ) 00427 $ RETURN 00428 * 00429 * Decode DIST 00430 * 00431 IF( LSAME( DIST, 'U' ) ) THEN 00432 IDIST = 1 00433 ELSE IF( LSAME( DIST, 'S' ) ) THEN 00434 IDIST = 2 00435 ELSE IF( LSAME( DIST, 'N' ) ) THEN 00436 IDIST = 3 00437 ELSE IF( LSAME( DIST, 'D' ) ) THEN 00438 IDIST = 4 00439 ELSE 00440 IDIST = -1 00441 END IF 00442 * 00443 * Decode SYM 00444 * 00445 IF( LSAME( SYM, 'H' ) ) THEN 00446 ISYM = 0 00447 ELSE IF( LSAME( SYM, 'N' ) ) THEN 00448 ISYM = 1 00449 ELSE IF( LSAME( SYM, 'S' ) ) THEN 00450 ISYM = 2 00451 ELSE 00452 ISYM = -1 00453 END IF 00454 * 00455 * Decode RSIGN 00456 * 00457 IF( LSAME( RSIGN, 'F' ) ) THEN 00458 IRSIGN = 0 00459 ELSE IF( LSAME( RSIGN, 'T' ) ) THEN 00460 IRSIGN = 1 00461 ELSE 00462 IRSIGN = -1 00463 END IF 00464 * 00465 * Decode PIVTNG 00466 * 00467 IF( LSAME( PIVTNG, 'N' ) ) THEN 00468 IPVTNG = 0 00469 ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN 00470 IPVTNG = 0 00471 ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN 00472 IPVTNG = 1 00473 NPVTS = M 00474 ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN 00475 IPVTNG = 2 00476 NPVTS = N 00477 ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN 00478 IPVTNG = 3 00479 NPVTS = MIN( N, M ) 00480 ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN 00481 IPVTNG = 3 00482 NPVTS = MIN( N, M ) 00483 ELSE 00484 IPVTNG = -1 00485 END IF 00486 * 00487 * Decode GRADE 00488 * 00489 IF( LSAME( GRADE, 'N' ) ) THEN 00490 IGRADE = 0 00491 ELSE IF( LSAME( GRADE, 'L' ) ) THEN 00492 IGRADE = 1 00493 ELSE IF( LSAME( GRADE, 'R' ) ) THEN 00494 IGRADE = 2 00495 ELSE IF( LSAME( GRADE, 'B' ) ) THEN 00496 IGRADE = 3 00497 ELSE IF( LSAME( GRADE, 'E' ) ) THEN 00498 IGRADE = 4 00499 ELSE IF( LSAME( GRADE, 'H' ) ) THEN 00500 IGRADE = 5 00501 ELSE IF( LSAME( GRADE, 'S' ) ) THEN 00502 IGRADE = 6 00503 ELSE 00504 IGRADE = -1 00505 END IF 00506 * 00507 * Decode PACK 00508 * 00509 IF( LSAME( PACK, 'N' ) ) THEN 00510 IPACK = 0 00511 ELSE IF( LSAME( PACK, 'U' ) ) THEN 00512 IPACK = 1 00513 ELSE IF( LSAME( PACK, 'L' ) ) THEN 00514 IPACK = 2 00515 ELSE IF( LSAME( PACK, 'C' ) ) THEN 00516 IPACK = 3 00517 ELSE IF( LSAME( PACK, 'R' ) ) THEN 00518 IPACK = 4 00519 ELSE IF( LSAME( PACK, 'B' ) ) THEN 00520 IPACK = 5 00521 ELSE IF( LSAME( PACK, 'Q' ) ) THEN 00522 IPACK = 6 00523 ELSE IF( LSAME( PACK, 'Z' ) ) THEN 00524 IPACK = 7 00525 ELSE 00526 IPACK = -1 00527 END IF 00528 * 00529 * Set certain internal parameters 00530 * 00531 MNMIN = MIN( M, N ) 00532 KLL = MIN( KL, M-1 ) 00533 KUU = MIN( KU, N-1 ) 00534 * 00535 * If inv(DL) is used, check to see if DL has a zero entry. 00536 * 00537 DZERO = .FALSE. 00538 IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN 00539 DO 10 I = 1, M 00540 IF( DL( I ).EQ.CZERO ) 00541 $ DZERO = .TRUE. 00542 10 CONTINUE 00543 END IF 00544 * 00545 * Check values in IPIVOT 00546 * 00547 BADPVT = .FALSE. 00548 IF( IPVTNG.GT.0 ) THEN 00549 DO 20 J = 1, NPVTS 00550 IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) 00551 $ BADPVT = .TRUE. 00552 20 CONTINUE 00553 END IF 00554 * 00555 * Set INFO if an error 00556 * 00557 IF( M.LT.0 ) THEN 00558 INFO = -1 00559 ELSE IF( M.NE.N .AND. ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN 00560 INFO = -1 00561 ELSE IF( N.LT.0 ) THEN 00562 INFO = -2 00563 ELSE IF( IDIST.EQ.-1 ) THEN 00564 INFO = -3 00565 ELSE IF( ISYM.EQ.-1 ) THEN 00566 INFO = -5 00567 ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN 00568 INFO = -7 00569 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. 00570 $ COND.LT.ONE ) THEN 00571 INFO = -8 00572 ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. 00573 $ IRSIGN.EQ.-1 ) THEN 00574 INFO = -10 00575 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. 00576 $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. 00577 $ IGRADE.EQ.4 .OR. IGRADE.EQ.6 ) .AND. ISYM.EQ.0 ) .OR. 00578 $ ( ( IGRADE.EQ.1 .OR. IGRADE.EQ.2 .OR. IGRADE.EQ.3 .OR. 00579 $ IGRADE.EQ.4 .OR. IGRADE.EQ.5 ) .AND. ISYM.EQ.2 ) ) THEN 00580 INFO = -11 00581 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN 00582 INFO = -12 00583 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. 00584 $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. 00585 $ ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) THEN 00586 INFO = -13 00587 ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. 00588 $ IGRADE.EQ.5 .OR. IGRADE.EQ.6 ) .AND. 00589 $ ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. MODEL.NE.6 ) .AND. 00590 $ CONDL.LT.ONE ) THEN 00591 INFO = -14 00592 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. 00593 $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN 00594 INFO = -16 00595 ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. 00596 $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. 00597 $ CONDR.LT.ONE ) THEN 00598 INFO = -17 00599 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. 00600 $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ( ISYM.EQ.0 .OR. 00601 $ ISYM.EQ.2 ) ) ) THEN 00602 INFO = -18 00603 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN 00604 INFO = -19 00605 ELSE IF( KL.LT.0 ) THEN 00606 INFO = -20 00607 ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. KL.NE. 00608 $ KU ) ) THEN 00609 INFO = -21 00610 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN 00611 INFO = -22 00612 ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. 00613 $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. 00614 $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. 00615 $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. 00616 $ 0 .OR. M.NE.N ) ) ) THEN 00617 INFO = -24 00618 ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. 00619 $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. 00620 $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. 00621 $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. 00622 $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN 00623 INFO = -26 00624 END IF 00625 * 00626 IF( INFO.NE.0 ) THEN 00627 CALL XERBLA( 'CLATMR', -INFO ) 00628 RETURN 00629 END IF 00630 * 00631 * Decide if we can pivot consistently 00632 * 00633 FULBND = .FALSE. 00634 IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) 00635 $ FULBND = .TRUE. 00636 * 00637 * Initialize random number generator 00638 * 00639 DO 30 I = 1, 4 00640 ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) 00641 30 CONTINUE 00642 * 00643 ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 00644 * 00645 * 2) Set up D, DL, and DR, if indicated. 00646 * 00647 * Compute D according to COND and MODE 00648 * 00649 CALL CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) 00650 IF( INFO.NE.0 ) THEN 00651 INFO = 1 00652 RETURN 00653 END IF 00654 IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN 00655 * 00656 * Scale by DMAX 00657 * 00658 TEMP = ABS( D( 1 ) ) 00659 DO 40 I = 2, MNMIN 00660 TEMP = MAX( TEMP, ABS( D( I ) ) ) 00661 40 CONTINUE 00662 IF( TEMP.EQ.ZERO .AND. DMAX.NE.CZERO ) THEN 00663 INFO = 2 00664 RETURN 00665 END IF 00666 IF( TEMP.NE.ZERO ) THEN 00667 CALPHA = DMAX / TEMP 00668 ELSE 00669 CALPHA = CONE 00670 END IF 00671 DO 50 I = 1, MNMIN 00672 D( I ) = CALPHA*D( I ) 00673 50 CONTINUE 00674 * 00675 END IF 00676 * 00677 * If matrix Hermitian, make D real 00678 * 00679 IF( ISYM.EQ.0 ) THEN 00680 DO 60 I = 1, MNMIN 00681 D( I ) = REAL( D( I ) ) 00682 60 CONTINUE 00683 END IF 00684 * 00685 * Compute DL if grading set 00686 * 00687 IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. 00688 $ 5 .OR. IGRADE.EQ.6 ) THEN 00689 CALL CLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) 00690 IF( INFO.NE.0 ) THEN 00691 INFO = 3 00692 RETURN 00693 END IF 00694 END IF 00695 * 00696 * Compute DR if grading set 00697 * 00698 IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN 00699 CALL CLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) 00700 IF( INFO.NE.0 ) THEN 00701 INFO = 4 00702 RETURN 00703 END IF 00704 END IF 00705 * 00706 * 3) Generate IWORK if pivoting 00707 * 00708 IF( IPVTNG.GT.0 ) THEN 00709 DO 70 I = 1, NPVTS 00710 IWORK( I ) = I 00711 70 CONTINUE 00712 IF( FULBND ) THEN 00713 DO 80 I = 1, NPVTS 00714 K = IPIVOT( I ) 00715 J = IWORK( I ) 00716 IWORK( I ) = IWORK( K ) 00717 IWORK( K ) = J 00718 80 CONTINUE 00719 ELSE 00720 DO 90 I = NPVTS, 1, -1 00721 K = IPIVOT( I ) 00722 J = IWORK( I ) 00723 IWORK( I ) = IWORK( K ) 00724 IWORK( K ) = J 00725 90 CONTINUE 00726 END IF 00727 END IF 00728 * 00729 * 4) Generate matrices for each kind of PACKing 00730 * Always sweep matrix columnwise (if symmetric, upper 00731 * half only) so that matrix generated does not depend 00732 * on PACK 00733 * 00734 IF( FULBND ) THEN 00735 * 00736 * Use CLATM3 so matrices generated with differing PIVOTing only 00737 * differ only in the order of their rows and/or columns. 00738 * 00739 IF( IPACK.EQ.0 ) THEN 00740 IF( ISYM.EQ.0 ) THEN 00741 DO 110 J = 1, N 00742 DO 100 I = 1, J 00743 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00744 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00745 $ IWORK, SPARSE ) 00746 A( ISUB, JSUB ) = CTEMP 00747 A( JSUB, ISUB ) = CONJG( CTEMP ) 00748 100 CONTINUE 00749 110 CONTINUE 00750 ELSE IF( ISYM.EQ.1 ) THEN 00751 DO 130 J = 1, N 00752 DO 120 I = 1, M 00753 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00754 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00755 $ IWORK, SPARSE ) 00756 A( ISUB, JSUB ) = CTEMP 00757 120 CONTINUE 00758 130 CONTINUE 00759 ELSE IF( ISYM.EQ.2 ) THEN 00760 DO 150 J = 1, N 00761 DO 140 I = 1, J 00762 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00763 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00764 $ IWORK, SPARSE ) 00765 A( ISUB, JSUB ) = CTEMP 00766 A( JSUB, ISUB ) = CTEMP 00767 140 CONTINUE 00768 150 CONTINUE 00769 END IF 00770 * 00771 ELSE IF( IPACK.EQ.1 ) THEN 00772 * 00773 DO 170 J = 1, N 00774 DO 160 I = 1, J 00775 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, 00776 $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, 00777 $ SPARSE ) 00778 MNSUB = MIN( ISUB, JSUB ) 00779 MXSUB = MAX( ISUB, JSUB ) 00780 IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN 00781 A( MNSUB, MXSUB ) = CONJG( CTEMP ) 00782 ELSE 00783 A( MNSUB, MXSUB ) = CTEMP 00784 END IF 00785 IF( MNSUB.NE.MXSUB ) 00786 $ A( MXSUB, MNSUB ) = CZERO 00787 160 CONTINUE 00788 170 CONTINUE 00789 * 00790 ELSE IF( IPACK.EQ.2 ) THEN 00791 * 00792 DO 190 J = 1, N 00793 DO 180 I = 1, J 00794 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, 00795 $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, 00796 $ SPARSE ) 00797 MNSUB = MIN( ISUB, JSUB ) 00798 MXSUB = MAX( ISUB, JSUB ) 00799 IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN 00800 A( MXSUB, MNSUB ) = CONJG( CTEMP ) 00801 ELSE 00802 A( MXSUB, MNSUB ) = CTEMP 00803 END IF 00804 IF( MNSUB.NE.MXSUB ) 00805 $ A( MNSUB, MXSUB ) = CZERO 00806 180 CONTINUE 00807 190 CONTINUE 00808 * 00809 ELSE IF( IPACK.EQ.3 ) THEN 00810 * 00811 DO 210 J = 1, N 00812 DO 200 I = 1, J 00813 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, 00814 $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, 00815 $ SPARSE ) 00816 * 00817 * Compute K = location of (ISUB,JSUB) entry in packed 00818 * array 00819 * 00820 MNSUB = MIN( ISUB, JSUB ) 00821 MXSUB = MAX( ISUB, JSUB ) 00822 K = MXSUB*( MXSUB-1 ) / 2 + MNSUB 00823 * 00824 * Convert K to (IISUB,JJSUB) location 00825 * 00826 JJSUB = ( K-1 ) / LDA + 1 00827 IISUB = K - LDA*( JJSUB-1 ) 00828 * 00829 IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN 00830 A( IISUB, JJSUB ) = CONJG( CTEMP ) 00831 ELSE 00832 A( IISUB, JJSUB ) = CTEMP 00833 END IF 00834 200 CONTINUE 00835 210 CONTINUE 00836 * 00837 ELSE IF( IPACK.EQ.4 ) THEN 00838 * 00839 DO 230 J = 1, N 00840 DO 220 I = 1, J 00841 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, 00842 $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, 00843 $ SPARSE ) 00844 * 00845 * Compute K = location of (I,J) entry in packed array 00846 * 00847 MNSUB = MIN( ISUB, JSUB ) 00848 MXSUB = MAX( ISUB, JSUB ) 00849 IF( MNSUB.EQ.1 ) THEN 00850 K = MXSUB 00851 ELSE 00852 K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / 00853 $ 2 + MXSUB - MNSUB + 1 00854 END IF 00855 * 00856 * Convert K to (IISUB,JJSUB) location 00857 * 00858 JJSUB = ( K-1 ) / LDA + 1 00859 IISUB = K - LDA*( JJSUB-1 ) 00860 * 00861 IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN 00862 A( IISUB, JJSUB ) = CONJG( CTEMP ) 00863 ELSE 00864 A( IISUB, JJSUB ) = CTEMP 00865 END IF 00866 220 CONTINUE 00867 230 CONTINUE 00868 * 00869 ELSE IF( IPACK.EQ.5 ) THEN 00870 * 00871 DO 250 J = 1, N 00872 DO 240 I = J - KUU, J 00873 IF( I.LT.1 ) THEN 00874 A( J-I+1, I+N ) = CZERO 00875 ELSE 00876 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00877 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00878 $ IWORK, SPARSE ) 00879 MNSUB = MIN( ISUB, JSUB ) 00880 MXSUB = MAX( ISUB, JSUB ) 00881 IF( MXSUB.EQ.JSUB .AND. ISYM.EQ.0 ) THEN 00882 A( MXSUB-MNSUB+1, MNSUB ) = CONJG( CTEMP ) 00883 ELSE 00884 A( MXSUB-MNSUB+1, MNSUB ) = CTEMP 00885 END IF 00886 END IF 00887 240 CONTINUE 00888 250 CONTINUE 00889 * 00890 ELSE IF( IPACK.EQ.6 ) THEN 00891 * 00892 DO 270 J = 1, N 00893 DO 260 I = J - KUU, J 00894 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, 00895 $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, 00896 $ SPARSE ) 00897 MNSUB = MIN( ISUB, JSUB ) 00898 MXSUB = MAX( ISUB, JSUB ) 00899 IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN 00900 A( MNSUB-MXSUB+KUU+1, MXSUB ) = CONJG( CTEMP ) 00901 ELSE 00902 A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP 00903 END IF 00904 260 CONTINUE 00905 270 CONTINUE 00906 * 00907 ELSE IF( IPACK.EQ.7 ) THEN 00908 * 00909 IF( ISYM.NE.1 ) THEN 00910 DO 290 J = 1, N 00911 DO 280 I = J - KUU, J 00912 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00913 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00914 $ IWORK, SPARSE ) 00915 MNSUB = MIN( ISUB, JSUB ) 00916 MXSUB = MAX( ISUB, JSUB ) 00917 IF( I.LT.1 ) 00918 $ A( J-I+1+KUU, I+N ) = CZERO 00919 IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN 00920 A( MNSUB-MXSUB+KUU+1, MXSUB ) = CONJG( CTEMP ) 00921 ELSE 00922 A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP 00923 END IF 00924 IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) THEN 00925 IF( MNSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN 00926 A( MXSUB-MNSUB+1+KUU, 00927 $ MNSUB ) = CONJG( CTEMP ) 00928 ELSE 00929 A( MXSUB-MNSUB+1+KUU, MNSUB ) = CTEMP 00930 END IF 00931 END IF 00932 280 CONTINUE 00933 290 CONTINUE 00934 ELSE IF( ISYM.EQ.1 ) THEN 00935 DO 310 J = 1, N 00936 DO 300 I = J - KUU, J + KLL 00937 CTEMP = CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, 00938 $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, 00939 $ IWORK, SPARSE ) 00940 A( ISUB-JSUB+KUU+1, JSUB ) = CTEMP 00941 300 CONTINUE 00942 310 CONTINUE 00943 END IF 00944 * 00945 END IF 00946 * 00947 ELSE 00948 * 00949 * Use CLATM2 00950 * 00951 IF( IPACK.EQ.0 ) THEN 00952 IF( ISYM.EQ.0 ) THEN 00953 DO 330 J = 1, N 00954 DO 320 I = 1, J 00955 A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, 00956 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 00957 $ IWORK, SPARSE ) 00958 A( J, I ) = CONJG( A( I, J ) ) 00959 320 CONTINUE 00960 330 CONTINUE 00961 ELSE IF( ISYM.EQ.1 ) THEN 00962 DO 350 J = 1, N 00963 DO 340 I = 1, M 00964 A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, 00965 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 00966 $ IWORK, SPARSE ) 00967 340 CONTINUE 00968 350 CONTINUE 00969 ELSE IF( ISYM.EQ.2 ) THEN 00970 DO 370 J = 1, N 00971 DO 360 I = 1, J 00972 A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, 00973 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 00974 $ IWORK, SPARSE ) 00975 A( J, I ) = A( I, J ) 00976 360 CONTINUE 00977 370 CONTINUE 00978 END IF 00979 * 00980 ELSE IF( IPACK.EQ.1 ) THEN 00981 * 00982 DO 390 J = 1, N 00983 DO 380 I = 1, J 00984 A( I, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, 00985 $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) 00986 IF( I.NE.J ) 00987 $ A( J, I ) = CZERO 00988 380 CONTINUE 00989 390 CONTINUE 00990 * 00991 ELSE IF( IPACK.EQ.2 ) THEN 00992 * 00993 DO 410 J = 1, N 00994 DO 400 I = 1, J 00995 IF( ISYM.EQ.0 ) THEN 00996 A( J, I ) = CONJG( CLATM2( M, N, I, J, KL, KU, 00997 $ IDIST, ISEED, D, IGRADE, DL, DR, 00998 $ IPVTNG, IWORK, SPARSE ) ) 00999 ELSE 01000 A( J, I ) = CLATM2( M, N, I, J, KL, KU, IDIST, 01001 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 01002 $ IWORK, SPARSE ) 01003 END IF 01004 IF( I.NE.J ) 01005 $ A( I, J ) = CZERO 01006 400 CONTINUE 01007 410 CONTINUE 01008 * 01009 ELSE IF( IPACK.EQ.3 ) THEN 01010 * 01011 ISUB = 0 01012 JSUB = 1 01013 DO 430 J = 1, N 01014 DO 420 I = 1, J 01015 ISUB = ISUB + 1 01016 IF( ISUB.GT.LDA ) THEN 01017 ISUB = 1 01018 JSUB = JSUB + 1 01019 END IF 01020 A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, IDIST, 01021 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 01022 $ IWORK, SPARSE ) 01023 420 CONTINUE 01024 430 CONTINUE 01025 * 01026 ELSE IF( IPACK.EQ.4 ) THEN 01027 * 01028 IF( ISYM.EQ.0 .OR. ISYM.EQ.2 ) THEN 01029 DO 450 J = 1, N 01030 DO 440 I = 1, J 01031 * 01032 * Compute K = location of (I,J) entry in packed array 01033 * 01034 IF( I.EQ.1 ) THEN 01035 K = J 01036 ELSE 01037 K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + 01038 $ J - I + 1 01039 END IF 01040 * 01041 * Convert K to (ISUB,JSUB) location 01042 * 01043 JSUB = ( K-1 ) / LDA + 1 01044 ISUB = K - LDA*( JSUB-1 ) 01045 * 01046 A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, 01047 $ IDIST, ISEED, D, IGRADE, DL, DR, 01048 $ IPVTNG, IWORK, SPARSE ) 01049 IF( ISYM.EQ.0 ) 01050 $ A( ISUB, JSUB ) = CONJG( A( ISUB, JSUB ) ) 01051 440 CONTINUE 01052 450 CONTINUE 01053 ELSE 01054 ISUB = 0 01055 JSUB = 1 01056 DO 470 J = 1, N 01057 DO 460 I = J, M 01058 ISUB = ISUB + 1 01059 IF( ISUB.GT.LDA ) THEN 01060 ISUB = 1 01061 JSUB = JSUB + 1 01062 END IF 01063 A( ISUB, JSUB ) = CLATM2( M, N, I, J, KL, KU, 01064 $ IDIST, ISEED, D, IGRADE, DL, DR, 01065 $ IPVTNG, IWORK, SPARSE ) 01066 460 CONTINUE 01067 470 CONTINUE 01068 END IF 01069 * 01070 ELSE IF( IPACK.EQ.5 ) THEN 01071 * 01072 DO 490 J = 1, N 01073 DO 480 I = J - KUU, J 01074 IF( I.LT.1 ) THEN 01075 A( J-I+1, I+N ) = CZERO 01076 ELSE 01077 IF( ISYM.EQ.0 ) THEN 01078 A( J-I+1, I ) = CONJG( CLATM2( M, N, I, J, KL, 01079 $ KU, IDIST, ISEED, D, IGRADE, DL, 01080 $ DR, IPVTNG, IWORK, SPARSE ) ) 01081 ELSE 01082 A( J-I+1, I ) = CLATM2( M, N, I, J, KL, KU, 01083 $ IDIST, ISEED, D, IGRADE, DL, DR, 01084 $ IPVTNG, IWORK, SPARSE ) 01085 END IF 01086 END IF 01087 480 CONTINUE 01088 490 CONTINUE 01089 * 01090 ELSE IF( IPACK.EQ.6 ) THEN 01091 * 01092 DO 510 J = 1, N 01093 DO 500 I = J - KUU, J 01094 A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, IDIST, 01095 $ ISEED, D, IGRADE, DL, DR, IPVTNG, 01096 $ IWORK, SPARSE ) 01097 500 CONTINUE 01098 510 CONTINUE 01099 * 01100 ELSE IF( IPACK.EQ.7 ) THEN 01101 * 01102 IF( ISYM.NE.1 ) THEN 01103 DO 530 J = 1, N 01104 DO 520 I = J - KUU, J 01105 A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, 01106 $ IDIST, ISEED, D, IGRADE, DL, 01107 $ DR, IPVTNG, IWORK, SPARSE ) 01108 IF( I.LT.1 ) 01109 $ A( J-I+1+KUU, I+N ) = CZERO 01110 IF( I.GE.1 .AND. I.NE.J ) THEN 01111 IF( ISYM.EQ.0 ) THEN 01112 A( J-I+1+KUU, I ) = CONJG( A( I-J+KUU+1, 01113 $ J ) ) 01114 ELSE 01115 A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) 01116 END IF 01117 END IF 01118 520 CONTINUE 01119 530 CONTINUE 01120 ELSE IF( ISYM.EQ.1 ) THEN 01121 DO 550 J = 1, N 01122 DO 540 I = J - KUU, J + KLL 01123 A( I-J+KUU+1, J ) = CLATM2( M, N, I, J, KL, KU, 01124 $ IDIST, ISEED, D, IGRADE, DL, 01125 $ DR, IPVTNG, IWORK, SPARSE ) 01126 540 CONTINUE 01127 550 CONTINUE 01128 END IF 01129 * 01130 END IF 01131 * 01132 END IF 01133 * 01134 * 5) Scaling the norm 01135 * 01136 IF( IPACK.EQ.0 ) THEN 01137 ONORM = CLANGE( 'M', M, N, A, LDA, TEMPA ) 01138 ELSE IF( IPACK.EQ.1 ) THEN 01139 ONORM = CLANSY( 'M', 'U', N, A, LDA, TEMPA ) 01140 ELSE IF( IPACK.EQ.2 ) THEN 01141 ONORM = CLANSY( 'M', 'L', N, A, LDA, TEMPA ) 01142 ELSE IF( IPACK.EQ.3 ) THEN 01143 ONORM = CLANSP( 'M', 'U', N, A, TEMPA ) 01144 ELSE IF( IPACK.EQ.4 ) THEN 01145 ONORM = CLANSP( 'M', 'L', N, A, TEMPA ) 01146 ELSE IF( IPACK.EQ.5 ) THEN 01147 ONORM = CLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) 01148 ELSE IF( IPACK.EQ.6 ) THEN 01149 ONORM = CLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) 01150 ELSE IF( IPACK.EQ.7 ) THEN 01151 ONORM = CLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) 01152 END IF 01153 * 01154 IF( ANORM.GE.ZERO ) THEN 01155 * 01156 IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN 01157 * 01158 * Desired scaling impossible 01159 * 01160 INFO = 5 01161 RETURN 01162 * 01163 ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. 01164 $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN 01165 * 01166 * Scale carefully to avoid over / underflow 01167 * 01168 IF( IPACK.LE.2 ) THEN 01169 DO 560 J = 1, N 01170 CALL CSSCAL( M, ONE / ONORM, A( 1, J ), 1 ) 01171 CALL CSSCAL( M, ANORM, A( 1, J ), 1 ) 01172 560 CONTINUE 01173 * 01174 ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN 01175 * 01176 CALL CSSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) 01177 CALL CSSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) 01178 * 01179 ELSE IF( IPACK.GE.5 ) THEN 01180 * 01181 DO 570 J = 1, N 01182 CALL CSSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) 01183 CALL CSSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) 01184 570 CONTINUE 01185 * 01186 END IF 01187 * 01188 ELSE 01189 * 01190 * Scale straightforwardly 01191 * 01192 IF( IPACK.LE.2 ) THEN 01193 DO 580 J = 1, N 01194 CALL CSSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) 01195 580 CONTINUE 01196 * 01197 ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN 01198 * 01199 CALL CSSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) 01200 * 01201 ELSE IF( IPACK.GE.5 ) THEN 01202 * 01203 DO 590 J = 1, N 01204 CALL CSSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) 01205 590 CONTINUE 01206 END IF 01207 * 01208 END IF 01209 * 01210 END IF 01211 * 01212 * End of CLATMR 01213 * 01214 END
1.7.3 
