00001 /* clatm3.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Complex */ VOID clatm3_(complex * ret_val, integer *m, integer *n, integer 00017 *i__, integer *j, integer *isub, integer *jsub, integer *kl, integer * 00018 ku, integer *idist, integer *iseed, complex *d__, integer *igrade, 00019 complex *dl, complex *dr, integer *ipvtng, integer *iwork, real * 00020 sparse) 00021 { 00022 /* System generated locals */ 00023 integer i__1, i__2; 00024 complex q__1, q__2, q__3; 00025 00026 /* Builtin functions */ 00027 void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); 00028 00029 /* Local variables */ 00030 complex ctemp; 00031 extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); 00032 extern doublereal slaran_(integer *); 00033 00034 00035 /* -- LAPACK auxiliary test routine (version 3.1) -- */ 00036 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ 00037 /* November 2006 */ 00038 00039 /* .. Scalar Arguments .. */ 00040 00041 /* .. */ 00042 00043 /* .. Array Arguments .. */ 00044 00045 /* .. */ 00046 00047 /* Purpose */ 00048 /* ======= */ 00049 00050 /* CLATM3 returns the (ISUB,JSUB) entry of a random matrix of */ 00051 /* dimension (M, N) described by the other paramters. (ISUB,JSUB) */ 00052 /* is the final position of the (I,J) entry after pivoting */ 00053 /* according to IPVTNG and IWORK. CLATM3 is called by the */ 00054 /* CLATMR routine in order to build random test matrices. No error */ 00055 /* checking on parameters is done, because this routine is called in */ 00056 /* a tight loop by CLATMR which has already checked the parameters. */ 00057 00058 /* Use of CLATM3 differs from CLATM2 in the order in which the random */ 00059 /* number generator is called to fill in random matrix entries. */ 00060 /* With CLATM2, the generator is called to fill in the pivoted matrix */ 00061 /* columnwise. With CLATM3, the generator is called to fill in the */ 00062 /* matrix columnwise, after which it is pivoted. Thus, CLATM3 can */ 00063 /* be used to construct random matrices which differ only in their */ 00064 /* order of rows and/or columns. CLATM2 is used to construct band */ 00065 /* matrices while avoiding calling the random number generator for */ 00066 /* entries outside the band (and therefore generating random numbers */ 00067 /* in different orders for different pivot orders). */ 00068 00069 /* The matrix whose (ISUB,JSUB) entry is returned is constructed as */ 00070 /* follows (this routine only computes one entry): */ 00071 00072 /* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */ 00073 /* (this is convenient for generating matrices in band format). */ 00074 00075 /* Generate a matrix A with random entries of distribution IDIST. */ 00076 00077 /* Set the diagonal to D. */ 00078 00079 /* Grade the matrix, if desired, from the left (by DL) and/or */ 00080 /* from the right (by DR or DL) as specified by IGRADE. */ 00081 00082 /* Permute, if desired, the rows and/or columns as specified by */ 00083 /* IPVTNG and IWORK. */ 00084 00085 /* Band the matrix to have lower bandwidth KL and upper */ 00086 /* bandwidth KU. */ 00087 00088 /* Set random entries to zero as specified by SPARSE. */ 00089 00090 /* Arguments */ 00091 /* ========= */ 00092 00093 /* M - INTEGER */ 00094 /* Number of rows of matrix. Not modified. */ 00095 00096 /* N - INTEGER */ 00097 /* Number of columns of matrix. Not modified. */ 00098 00099 /* I - INTEGER */ 00100 /* Row of unpivoted entry to be returned. Not modified. */ 00101 00102 /* J - INTEGER */ 00103 /* Column of unpivoted entry to be returned. Not modified. */ 00104 00105 /* ISUB - INTEGER */ 00106 /* Row of pivoted entry to be returned. Changed on exit. */ 00107 00108 /* JSUB - INTEGER */ 00109 /* Column of pivoted entry to be returned. Changed on exit. */ 00110 00111 /* KL - INTEGER */ 00112 /* Lower bandwidth. Not modified. */ 00113 00114 /* KU - INTEGER */ 00115 /* Upper bandwidth. Not modified. */ 00116 00117 /* IDIST - INTEGER */ 00118 /* On entry, IDIST specifies the type of distribution to be */ 00119 /* used to generate a random matrix . */ 00120 /* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ 00121 /* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ 00122 /* 3 => real and imaginary parts each NORMAL( 0, 1 ) */ 00123 /* 4 => complex number uniform in DISK( 0 , 1 ) */ 00124 /* Not modified. */ 00125 00126 /* ISEED - INTEGER array of dimension ( 4 ) */ 00127 /* Seed for random number generator. */ 00128 /* Changed on exit. */ 00129 00130 /* D - COMPLEX array of dimension ( MIN( I , J ) ) */ 00131 /* Diagonal entries of matrix. Not modified. */ 00132 00133 /* IGRADE - INTEGER */ 00134 /* Specifies grading of matrix as follows: */ 00135 /* 0 => no grading */ 00136 /* 1 => matrix premultiplied by diag( DL ) */ 00137 /* 2 => matrix postmultiplied by diag( DR ) */ 00138 /* 3 => matrix premultiplied by diag( DL ) and */ 00139 /* postmultiplied by diag( DR ) */ 00140 /* 4 => matrix premultiplied by diag( DL ) and */ 00141 /* postmultiplied by inv( diag( DL ) ) */ 00142 /* 5 => matrix premultiplied by diag( DL ) and */ 00143 /* postmultiplied by diag( CONJG(DL) ) */ 00144 /* 6 => matrix premultiplied by diag( DL ) and */ 00145 /* postmultiplied by diag( DL ) */ 00146 /* Not modified. */ 00147 00148 /* DL - COMPLEX array ( I or J, as appropriate ) */ 00149 /* Left scale factors for grading matrix. Not modified. */ 00150 00151 /* DR - COMPLEX array ( I or J, as appropriate ) */ 00152 /* Right scale factors for grading matrix. Not modified. */ 00153 00154 /* IPVTNG - INTEGER */ 00155 /* On entry specifies pivoting permutations as follows: */ 00156 /* 0 => none. */ 00157 /* 1 => row pivoting. */ 00158 /* 2 => column pivoting. */ 00159 /* 3 => full pivoting, i.e., on both sides. */ 00160 /* Not modified. */ 00161 00162 /* IWORK - INTEGER array ( I or J, as appropriate ) */ 00163 /* This array specifies the permutation used. The */ 00164 /* row (or column) originally in position K is in */ 00165 /* position IWORK( K ) after pivoting. */ 00166 /* This differs from IWORK for CLATM2. Not modified. */ 00167 00168 /* SPARSE - REAL between 0. and 1. */ 00169 /* On entry specifies the sparsity of the matrix */ 00170 /* if sparse matix is to be generated. */ 00171 /* SPARSE should lie between 0 and 1. */ 00172 /* A uniform ( 0, 1 ) random number x is generated and */ 00173 /* compared to SPARSE; if x is larger the matrix entry */ 00174 /* is unchanged and if x is smaller the entry is set */ 00175 /* to zero. Thus on the average a fraction SPARSE of the */ 00176 /* entries will be set to zero. */ 00177 /* Not modified. */ 00178 00179 /* ===================================================================== */ 00180 00181 /* .. Parameters .. */ 00182 00183 /* .. */ 00184 00185 /* .. Local Scalars .. */ 00186 00187 /* .. */ 00188 00189 /* .. External Functions .. */ 00190 00191 /* .. */ 00192 00193 /* .. Intrinsic Functions .. */ 00194 00195 /* .. */ 00196 00197 /* ----------------------------------------------------------------------- */ 00198 00199 /* .. Executable Statements .. */ 00200 00201 00202 /* Check for I and J in range */ 00203 00204 /* Parameter adjustments */ 00205 --iwork; 00206 --dr; 00207 --dl; 00208 --d__; 00209 --iseed; 00210 00211 /* Function Body */ 00212 if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { 00213 *isub = *i__; 00214 *jsub = *j; 00215 ret_val->r = 0.f, ret_val->i = 0.f; 00216 return ; 00217 } 00218 00219 /* Compute subscripts depending on IPVTNG */ 00220 00221 if (*ipvtng == 0) { 00222 *isub = *i__; 00223 *jsub = *j; 00224 } else if (*ipvtng == 1) { 00225 *isub = iwork[*i__]; 00226 *jsub = *j; 00227 } else if (*ipvtng == 2) { 00228 *isub = *i__; 00229 *jsub = iwork[*j]; 00230 } else if (*ipvtng == 3) { 00231 *isub = iwork[*i__]; 00232 *jsub = iwork[*j]; 00233 } 00234 00235 /* Check for banding */ 00236 00237 if (*jsub > *isub + *ku || *jsub < *isub - *kl) { 00238 ret_val->r = 0.f, ret_val->i = 0.f; 00239 return ; 00240 } 00241 00242 /* Check for sparsity */ 00243 00244 if (*sparse > 0.f) { 00245 if (slaran_(&iseed[1]) < *sparse) { 00246 ret_val->r = 0.f, ret_val->i = 0.f; 00247 return ; 00248 } 00249 } 00250 00251 /* Compute entry and grade it according to IGRADE */ 00252 00253 if (*i__ == *j) { 00254 i__1 = *i__; 00255 ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i; 00256 } else { 00257 clarnd_(&q__1, idist, &iseed[1]); 00258 ctemp.r = q__1.r, ctemp.i = q__1.i; 00259 } 00260 if (*igrade == 1) { 00261 i__1 = *i__; 00262 q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i = 00263 ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; 00264 ctemp.r = q__1.r, ctemp.i = q__1.i; 00265 } else if (*igrade == 2) { 00266 i__1 = *j; 00267 q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i = 00268 ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r; 00269 ctemp.r = q__1.r, ctemp.i = q__1.i; 00270 } else if (*igrade == 3) { 00271 i__1 = *i__; 00272 q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 00273 ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; 00274 i__2 = *j; 00275 q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r * 00276 dr[i__2].i + q__2.i * dr[i__2].r; 00277 ctemp.r = q__1.r, ctemp.i = q__1.i; 00278 } else if (*igrade == 4 && *i__ != *j) { 00279 i__1 = *i__; 00280 q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 00281 ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; 00282 c_div(&q__1, &q__2, &dl[*j]); 00283 ctemp.r = q__1.r, ctemp.i = q__1.i; 00284 } else if (*igrade == 5) { 00285 i__1 = *i__; 00286 q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 00287 ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; 00288 r_cnjg(&q__3, &dl[*j]); 00289 q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i 00290 + q__2.i * q__3.r; 00291 ctemp.r = q__1.r, ctemp.i = q__1.i; 00292 } else if (*igrade == 6) { 00293 i__1 = *i__; 00294 q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 00295 ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; 00296 i__2 = *j; 00297 q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r * 00298 dl[i__2].i + q__2.i * dl[i__2].r; 00299 ctemp.r = q__1.r, ctemp.i = q__1.i; 00300 } 00301 ret_val->r = ctemp.r, ret_val->i = ctemp.i; 00302 return ; 00303 00304 /* End of CLATM3 */ 00305 00306 } /* clatm3_ */