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