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