/* Subroutine */ int zlacn2_(integer *n, doublecomplex *v, doublecomplex *x, doublereal *est, integer *kase, integer *isave) { /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1, d__2; doublecomplex z__1; /* Builtin functions */ double z_abs(doublecomplex *), d_imag(doublecomplex *); /* Local variables */ integer i__; doublereal temp, absxi; integer jlast; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern integer izmax1_(integer *, doublecomplex *, integer *); extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_( char *); doublereal safmin, altsgn, estold; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLACN2 estimates the 1-norm of a square, complex matrix A. */ /* Reverse communication is used for evaluating matrix-vector products. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix. N >= 1. */ /* V (workspace) COMPLEX*16 array, dimension (N) */ /* On the final return, V = A*W, where EST = norm(V)/norm(W) */ /* (W is not returned). */ /* X (input/output) COMPLEX*16 array, dimension (N) */ /* On an intermediate return, X should be overwritten by */ /* A * X, if KASE=1, */ /* A' * X, if KASE=2, */ /* where A' is the conjugate transpose of A, and ZLACN2 must be */ /* re-called with all the other parameters unchanged. */ /* EST (input/output) DOUBLE PRECISION */ /* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ /* unchanged from the previous call to ZLACN2. */ /* On exit, EST is an estimate (a lower bound) for norm(A). */ /* KASE (input/output) INTEGER */ /* On the initial call to ZLACN2, KASE should be 0. */ /* On an intermediate return, KASE will be 1 or 2, indicating */ /* whether X should be overwritten by A * X or A' * X. */ /* On the final return from ZLACN2, KASE will again be 0. */ /* ISAVE (input/output) INTEGER array, dimension (3) */ /* ISAVE is used to save variables between calls to ZLACN2 */ /* Further Details */ /* ======= ======= */ /* Contributed by Nick Higham, University of Manchester. */ /* Originally named CONEST, dated March 16, 1988. */ /* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ /* a real or complex matrix, with applications to condition estimation", */ /* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ /* Last modified: April, 1999 */ /* This is a thread safe version of ZLACON, which uses the array ISAVE */ /* in place of a SAVE statement, as follows: */ /* ZLACON ZLACN2 */ /* JUMP ISAVE(1) */ /* J ISAVE(2) */ /* ITER ISAVE(3) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --isave; --x; --v; /* Function Body */ safmin = dlamch_("Safe minimum"); if (*kase == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d__1 = 1. / (doublereal) (*n); z__1.r = d__1, z__1.i = 0.; x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* L10: */ } *kase = 1; isave[1] = 1; return 0; } switch (isave[1]) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L90; case 5: goto L120; } /* ................ ENTRY (ISAVE( 1 ) = 1) */ /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ L20: if (*n == 1) { v[1].r = x[1].r, v[1].i = x[1].i; *est = z_abs(&v[1]); /* ... QUIT */ goto L130; } *est = dzsum1_(n, &x[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { absxi = z_abs(&x[i__]); if (absxi > safmin) { i__2 = i__; i__3 = i__; d__1 = x[i__3].r / absxi; d__2 = d_imag(&x[i__]) / absxi; z__1.r = d__1, z__1.i = d__2; x[i__2].r = z__1.r, x[i__2].i = z__1.i; } else { i__2 = i__; x[i__2].r = 1., x[i__2].i = 0.; } /* L30: */ } *kase = 2; isave[1] = 2; return 0; /* ................ ENTRY (ISAVE( 1 ) = 2) */ /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ L40: isave[2] = izmax1_(n, &x[1], &c__1); isave[3] = 2; /* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ L50: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; x[i__2].r = 0., x[i__2].i = 0.; /* L60: */ } i__1 = isave[2]; x[i__1].r = 1., x[i__1].i = 0.; *kase = 1; isave[1] = 3; return 0; /* ................ ENTRY (ISAVE( 1 ) = 3) */ /* X HAS BEEN OVERWRITTEN BY A*X. */ L70: zcopy_(n, &x[1], &c__1, &v[1], &c__1); estold = *est; *est = dzsum1_(n, &v[1], &c__1); /* TEST FOR CYCLING. */ if (*est <= estold) { goto L100; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { absxi = z_abs(&x[i__]); if (absxi > safmin) { i__2 = i__; i__3 = i__; d__1 = x[i__3].r / absxi; d__2 = d_imag(&x[i__]) / absxi; z__1.r = d__1, z__1.i = d__2; x[i__2].r = z__1.r, x[i__2].i = z__1.i; } else { i__2 = i__; x[i__2].r = 1., x[i__2].i = 0.; } /* L80: */ } *kase = 2; isave[1] = 4; return 0; /* ................ ENTRY (ISAVE( 1 ) = 4) */ /* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ L90: jlast = isave[2]; isave[2] = izmax1_(n, &x[1], &c__1); if (z_abs(&x[jlast]) != z_abs(&x[isave[2]]) && isave[3] < 5) { ++isave[3]; goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ L100: altsgn = 1.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.); z__1.r = d__1, z__1.i = 0.; x[i__2].r = z__1.r, x[i__2].i = z__1.i; altsgn = -altsgn; /* L110: */ } *kase = 1; isave[1] = 5; return 0; /* ................ ENTRY (ISAVE( 1 ) = 5) */ /* X HAS BEEN OVERWRITTEN BY A*X. */ L120: temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; if (temp > *est) { zcopy_(n, &x[1], &c__1, &v[1], &c__1); *est = temp; } L130: *kase = 0; return 0; /* End of ZLACN2 */ } /* zlacn2_ */
int zlacon_(int *n, doublecomplex *v, doublecomplex *x, double *est, int *kase) { /* Table of constant values */ int c__1 = 1; doublecomplex zero = {0.0, 0.0}; doublecomplex one = {1.0, 0.0}; /* System generated locals */ double d__1; /* Local variables */ static int iter; static int jump, jlast; static double altsgn, estold; static int i, j; double temp; double safmin; extern double dlamch_(char *); extern int izmax1_(int *, doublecomplex *, int *); extern double dzsum1_(int *, doublecomplex *, int *); safmin = dlamch_("Safe minimum"); if ( *kase == 0 ) { for (i = 0; i < *n; ++i) { x[i].r = 1. / (double) (*n); x[i].i = 0.; } *kase = 1; jump = 1; return 0; } switch (jump) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L110; case 5: goto L140; } /* ................ ENTRY (JUMP = 1) FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ L20: if (*n == 1) { v[0] = x[0]; *est = z_abs(&v[0]); /* ... QUIT */ goto L150; } *est = dzsum1_(n, x, &c__1); for (i = 0; i < *n; ++i) { d__1 = z_abs(&x[i]); if (d__1 > safmin) { d__1 = 1 / d__1; x[i].r *= d__1; x[i].i *= d__1; } else { x[i] = one; } } *kase = 2; jump = 2; return 0; /* ................ ENTRY (JUMP = 2) FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ L40: j = izmax1_(n, &x[0], &c__1); --j; iter = 2; /* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ L50: for (i = 0; i < *n; ++i) x[i] = zero; x[j] = one; *kase = 1; jump = 3; return 0; /* ................ ENTRY (JUMP = 3) X HAS BEEN OVERWRITTEN BY A*X. */ L70: #ifdef _CRAY CCOPY(n, x, &c__1, v, &c__1); #else zcopy_(n, x, &c__1, v, &c__1); #endif estold = *est; *est = dzsum1_(n, v, &c__1); L90: /* TEST FOR CYCLING. */ if (*est <= estold) goto L120; for (i = 0; i < *n; ++i) { d__1 = z_abs(&x[i]); if (d__1 > safmin) { d__1 = 1 / d__1; x[i].r *= d__1; x[i].i *= d__1; } else { x[i] = one; } } *kase = 2; jump = 4; return 0; /* ................ ENTRY (JUMP = 4) X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */ L110: jlast = j; j = izmax1_(n, &x[0], &c__1); --j; if (x[jlast].r != (d__1 = x[j].r, fabs(d__1)) && iter < 5) { ++iter; goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ L120: altsgn = 1.; for (i = 1; i <= *n; ++i) { x[i-1].r = altsgn * ((double)(i - 1) / (double)(*n - 1) + 1.); x[i-1].i = 0.; altsgn = -altsgn; } *kase = 1; jump = 5; return 0; /* ................ ENTRY (JUMP = 5) X HAS BEEN OVERWRITTEN BY A*X. */ L140: temp = dzsum1_(n, x, &c__1) / (double)(*n * 3) * 2.; if (temp > *est) { #ifdef _CRAY CCOPY(n, &x[0], &c__1, &v[0], &c__1); #else zcopy_(n, &x[0], &c__1, &v[0], &c__1); #endif *est = temp; } L150: *kase = 0; return 0; } /* zlacon_ */
/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x, doublereal *est, integer *kase) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= ZLACON estimates the 1-norm of a square, complex matrix A. Reverse communication is used for evaluating matrix-vector products. Arguments ========= N (input) INTEGER The order of the matrix. N >= 1. V (workspace) COMPLEX*16 array, dimension (N) On the final return, V = A*W, where EST = norm(V)/norm(W) (W is not returned). X (input/output) COMPLEX*16 array, dimension (N) On an intermediate return, X should be overwritten by A * X, if KASE=1, A' * X, if KASE=2, where A' is the conjugate transpose of A, and ZLACON must be re-called with all the other parameters unchanged. EST (output) DOUBLE PRECISION An estimate (a lower bound) for norm(A). KASE (input/output) INTEGER On the initial call to ZLACON, KASE should be 0. On an intermediate return, KASE will be 1 or 2, indicating whether X should be overwritten by A * X or A' * X. On the final return from ZLACON, KASE will again be 0. Further Details ======= ======= Contributed by Nick Higham, University of Manchester. Originally named CONEST, dated March 16, 1988. Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of a real or complex matrix, with applications to condition estimation", ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. ===================================================================== Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; doublereal d__1; doublecomplex z__1, z__2; /* Builtin functions */ double z_abs(doublecomplex *); void z_div(doublecomplex *, doublecomplex *, doublecomplex *); /* Local variables */ static integer iter; static doublereal temp; static integer jump, i, j, jlast; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern integer izmax1_(integer *, doublecomplex *, integer *); extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_( char *); static doublereal safmin, altsgn, estold; #define X(I) x[(I)-1] #define V(I) v[(I)-1] safmin = dlamch_("Safe minimum"); if (*kase == 0) { i__1 = *n; for (i = 1; i <= *n; ++i) { i__2 = i; d__1 = 1. / (doublereal) (*n); z__1.r = d__1, z__1.i = 0.; X(i).r = z__1.r, X(i).i = z__1.i; /* L10: */ } *kase = 1; jump = 1; return 0; } switch (jump) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L90; case 5: goto L120; } /* ................ ENTRY (JUMP = 1) FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ L20: if (*n == 1) { V(1).r = X(1).r, V(1).i = X(1).i; *est = z_abs(&V(1)); /* ... QUIT */ goto L130; } *est = dzsum1_(n, &X(1), &c__1); i__1 = *n; for (i = 1; i <= *n; ++i) { if (z_abs(&X(i)) > safmin) { i__2 = i; d__1 = z_abs(&X(i)); z__2.r = d__1, z__2.i = 0.; z_div(&z__1, &X(i), &z__2); X(i).r = z__1.r, X(i).i = z__1.i; } else { i__2 = i; X(i).r = 1., X(i).i = 0.; } /* L30: */ } *kase = 2; jump = 2; return 0; /* ................ ENTRY (JUMP = 2) FIRST ITERATION. X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. */ L40: j = izmax1_(n, &X(1), &c__1); iter = 2; /* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ L50: i__1 = *n; for (i = 1; i <= *n; ++i) { i__2 = i; X(i).r = 0., X(i).i = 0.; /* L60: */ } i__1 = j; X(j).r = 1., X(j).i = 0.; *kase = 1; jump = 3; return 0; /* ................ ENTRY (JUMP = 3) X HAS BEEN OVERWRITTEN BY A*X. */ L70: zcopy_(n, &X(1), &c__1, &V(1), &c__1); estold = *est; *est = dzsum1_(n, &V(1), &c__1); /* TEST FOR CYCLING. */ if (*est <= estold) { goto L100; } i__1 = *n; for (i = 1; i <= *n; ++i) { if (z_abs(&X(i)) > safmin) { i__2 = i; d__1 = z_abs(&X(i)); z__2.r = d__1, z__2.i = 0.; z_div(&z__1, &X(i), &z__2); X(i).r = z__1.r, X(i).i = z__1.i; } else { i__2 = i; X(i).r = 1., X(i).i = 0.; } /* L80: */ } *kase = 2; jump = 4; return 0; /* ................ ENTRY (JUMP = 4) X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. */ L90: jlast = j; j = izmax1_(n, &X(1), &c__1); i__1 = jlast; i__2 = j; if (X(jlast).r != (d__1 = X(j).r, abs(d__1)) && iter < 5) { ++iter; goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ L100: altsgn = 1.; i__1 = *n; for (i = 1; i <= *n; ++i) { i__2 = i; d__1 = altsgn * ((doublereal) (i - 1) / (doublereal) (*n - 1) + 1.); z__1.r = d__1, z__1.i = 0.; X(i).r = z__1.r, X(i).i = z__1.i; altsgn = -altsgn; /* L110: */ } *kase = 1; jump = 5; return 0; /* ................ ENTRY (JUMP = 5) X HAS BEEN OVERWRITTEN BY A*X. */ L120: temp = dzsum1_(n, &X(1), &c__1) / (doublereal) (*n * 3) * 2.; if (temp > *est) { zcopy_(n, &X(1), &c__1, &V(1), &c__1); *est = temp; } L130: *kase = 0; return 0; /* End of ZLACON */ } /* zlacon_ */
/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x, doublereal *est, integer *kase) { /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ static integer i__, j, iter; static doublereal temp; static integer jump; static doublereal absxi; static integer jlast; static doublereal safmin, altsgn, estold; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZLACON estimates the 1-norm of a square, complex matrix A. */ /* Reverse communication is used for evaluating matrix-vector products. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix. N >= 1. */ /* V (workspace) COMPLEX*16 array, dimension (N) */ /* On the final return, V = A*W, where EST = norm(V)/norm(W) */ /* (W is not returned). */ /* X (input/output) COMPLEX*16 array, dimension (N) */ /* On an intermediate return, X should be overwritten by */ /* A * X, if KASE=1, */ /* A' * X, if KASE=2, */ /* where A' is the conjugate transpose of A, and ZLACON must be */ /* re-called with all the other parameters unchanged. */ /* EST (input/output) DOUBLE PRECISION */ /* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ /* unchanged from the previous call to ZLACON. */ /* On exit, EST is an estimate (a lower bound) for norm(A). */ /* KASE (input/output) INTEGER */ /* On the initial call to ZLACON, KASE should be 0. */ /* On an intermediate return, KASE will be 1 or 2, indicating */ /* whether X should be overwritten by A * X or A' * X. */ /* On the final return from ZLACON, KASE will again be 0. */ /* Further Details */ /* ======= ======= */ /* Contributed by Nick Higham, University of Manchester. */ /* Originally named CONEST, dated March 16, 1988. */ /* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ /* a real or complex matrix, with applications to condition estimation", */ /* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ /* Last modified: April, 1999 */ /* ===================================================================== */ /* Parameter adjustments */ --x; --v; /* Function Body */ safmin = dlamch_("Safe minimum"); if (*kase == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d__1 = 1. / (doublereal) (*n); z__1.r = d__1, z__1.i = 0.; x[i__2].r = z__1.r, x[i__2].i = z__1.i; } *kase = 1; jump = 1; return 0; } switch (jump) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L90; case 5: goto L120; } /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ L20: if (*n == 1) { v[1].r = x[1].r, v[1].i = x[1].i; *est = z_abs(&v[1]); goto L130; } *est = dzsum1_(n, &x[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { absxi = z_abs(&x[i__]); if (absxi > safmin) { i__2 = i__; i__3 = i__; d__1 = x[i__3].r / absxi; d__2 = d_imag(&x[i__]) / absxi; z__1.r = d__1, z__1.i = d__2; x[i__2].r = z__1.r, x[i__2].i = z__1.i; } else { i__2 = i__; x[i__2].r = 1., x[i__2].i = 0.; } } *kase = 2; jump = 2; return 0; /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ L40: j = izmax1_(n, &x[1], &c__1); iter = 2; L50: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; x[i__2].r = 0., x[i__2].i = 0.; } i__1 = j; x[i__1].r = 1., x[i__1].i = 0.; *kase = 1; jump = 3; return 0; /* X HAS BEEN OVERWRITTEN BY A*X. */ L70: zcopy_(n, &x[1], &c__1, &v[1], &c__1); estold = *est; *est = dzsum1_(n, &v[1], &c__1); /* TEST FOR CYCLING. */ if (*est <= estold) { goto L100; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { absxi = z_abs(&x[i__]); if (absxi > safmin) { i__2 = i__; i__3 = i__; d__1 = x[i__3].r / absxi; d__2 = d_imag(&x[i__]) / absxi; z__1.r = d__1, z__1.i = d__2; x[i__2].r = z__1.r, x[i__2].i = z__1.i; } else { i__2 = i__; x[i__2].r = 1., x[i__2].i = 0.; } } *kase = 2; jump = 4; return 0; /* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ L90: jlast = j; j = izmax1_(n, &x[1], &c__1); if (z_abs(&x[jlast]) != z_abs(&x[j]) && iter < 5) { ++iter; goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ L100: altsgn = 1.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.); z__1.r = d__1, z__1.i = 0.; x[i__2].r = z__1.r, x[i__2].i = z__1.i; altsgn = -altsgn; } *kase = 1; jump = 5; return 0; /* X HAS BEEN OVERWRITTEN BY A*X. */ L120: temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; if (temp > *est) { zcopy_(n, &x[1], &c__1, &v[1], &c__1); *est = temp; } L130: *kase = 0; return 0; /* End of ZLACON */ } /* zlacon_ */