cqrt13.c
Go to the documentation of this file.
00001 /* cqrt13.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 /* Table of constant values */
00017 
00018 static integer c__2 = 2;
00019 static integer c__1 = 1;
00020 static integer c__0 = 0;
00021 
00022 /* Subroutine */ int cqrt13_(integer *scale, integer *m, integer *n, complex *
00023         a, integer *lda, real *norma, integer *iseed)
00024 {
00025     /* System generated locals */
00026     integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
00027     real r__1, r__2, r__3;
00028     complex q__1, q__2;
00029 
00030     /* Builtin functions */
00031     double r_sign(real *, real *);
00032 
00033     /* Local variables */
00034     integer j, info;
00035     real dummy[1];
00036     extern /* Subroutine */ int slabad_(real *, real *);
00037     extern doublereal clange_(char *, integer *, integer *, complex *, 
00038             integer *, real *);
00039     extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, 
00040             real *, integer *, integer *, complex *, integer *, integer *);
00041     extern doublereal slamch_(char *);
00042     real bignum;
00043     extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, 
00044             complex *);
00045     extern doublereal scasum_(integer *, complex *, integer *);
00046     real smlnum;
00047 
00048 
00049 /*  -- LAPACK test routine (version 3.1) -- */
00050 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00051 /*     November 2006 */
00052 
00053 /*     .. Scalar Arguments .. */
00054 /*     .. */
00055 /*     .. Array Arguments .. */
00056 /*     .. */
00057 
00058 /*  Purpose */
00059 /*  ======= */
00060 
00061 /*  CQRT13 generates a full-rank matrix that may be scaled to have large */
00062 /*  or small norm. */
00063 
00064 /*  Arguments */
00065 /*  ========= */
00066 
00067 /*  SCALE   (input) INTEGER */
00068 /*          SCALE = 1: normally scaled matrix */
00069 /*          SCALE = 2: matrix scaled up */
00070 /*          SCALE = 3: matrix scaled down */
00071 
00072 /*  M       (input) INTEGER */
00073 /*          The number of rows of the matrix A. */
00074 
00075 /*  N       (input) INTEGER */
00076 /*          The number of columns of A. */
00077 
00078 /*  A       (output) COMPLEX array, dimension (LDA,N) */
00079 /*          The M-by-N matrix A. */
00080 
00081 /*  LDA     (input) INTEGER */
00082 /*          The leading dimension of the array A. */
00083 
00084 /*  NORMA   (output) REAL */
00085 /*          The one-norm of A. */
00086 
00087 /*  ISEED   (input/output) integer array, dimension (4) */
00088 /*          Seed for random number generator */
00089 
00090 /*  ===================================================================== */
00091 
00092 /*     .. Parameters .. */
00093 /*     .. */
00094 /*     .. Local Scalars .. */
00095 /*     .. */
00096 /*     .. External Functions .. */
00097 /*     .. */
00098 /*     .. External Subroutines .. */
00099 /*     .. */
00100 /*     .. Intrinsic Functions .. */
00101 /*     .. */
00102 /*     .. Local Arrays .. */
00103 /*     .. */
00104 /*     .. Executable Statements .. */
00105 
00106     /* Parameter adjustments */
00107     a_dim1 = *lda;
00108     a_offset = 1 + a_dim1;
00109     a -= a_offset;
00110     --iseed;
00111 
00112     /* Function Body */
00113     if (*m <= 0 || *n <= 0) {
00114         return 0;
00115     }
00116 
00117 /*     benign matrix */
00118 
00119     i__1 = *n;
00120     for (j = 1; j <= i__1; ++j) {
00121         clarnv_(&c__2, &iseed[1], m, &a[j * a_dim1 + 1]);
00122         if (j <= *m) {
00123             i__2 = j + j * a_dim1;
00124             i__3 = j + j * a_dim1;
00125             r__2 = scasum_(m, &a[j * a_dim1 + 1], &c__1);
00126             i__4 = j + j * a_dim1;
00127             r__3 = a[i__4].r;
00128             r__1 = r_sign(&r__2, &r__3);
00129             q__2.r = r__1, q__2.i = 0.f;
00130             q__1.r = a[i__3].r + q__2.r, q__1.i = a[i__3].i + q__2.i;
00131             a[i__2].r = q__1.r, a[i__2].i = q__1.i;
00132         }
00133 /* L10: */
00134     }
00135 
00136 /*     scaled versions */
00137 
00138     if (*scale != 1) {
00139         *norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
00140         smlnum = slamch_("Safe minimum");
00141         bignum = 1.f / smlnum;
00142         slabad_(&smlnum, &bignum);
00143         smlnum /= slamch_("Epsilon");
00144         bignum = 1.f / smlnum;
00145 
00146         if (*scale == 2) {
00147 
00148 /*           matrix scaled up */
00149 
00150             clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
00151                     a_offset], lda, &info);
00152         } else if (*scale == 3) {
00153 
00154 /*           matrix scaled down */
00155 
00156             clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
00157                     a_offset], lda, &info);
00158         }
00159     }
00160 
00161     *norma = clange_("One-norm", m, n, &a[a_offset], lda, dummy);
00162     return 0;
00163 
00164 /*     End of CQRT13 */
00165 
00166 } /* cqrt13_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:33