void f2c_zdotu(doublecomplex* retval, integer* N, doublecomplex* X, integer* incX, doublecomplex* Y, integer* incY) { zdotu_(retval, N, X, incX, Y, incY); }
doublecomplex zdotu( int n, doublecomplex *x, int incx, doublecomplex *y, int incy) { doublecomplex ans; #if defined( _WIN32 ) || defined( _WIN64 ) ans = zdotu_(&n, x, &incx, y, &incy); #else zdotusub_(&n, x, &incx, y, &incy, &ans); #endif return ans; }
/*! zcovector^T*zcovector operator (inner product) */ inline comple operator%(const zcovector& vecA, const zcovector& vecB) { VERBOSE_REPORT; #ifdef CPPL_DEBUG if(vecA.l!=vecB.l) { ERROR_REPORT; std::cerr << "These two vectors can not make a dot product." << std::endl << "Your input was (" << vecA.l << ") % (" << vecB.l << ")." << std::endl; exit(1); } #endif//CPPL_DEBUG comple val( zdotu_( vecA.l, vecA.array, 1, vecB.array, 1 ) ); return val; }
/*! zrovector^T*zrovector operator (inner product) */ inline std::complex<double> operator%(const zrovector& vecA, const zrovector& vecB) { #ifdef CPPL_VERBOSE std::cerr << "# [MARK] operator%(const zrovector&, const zrovector&)" << std::endl; #endif//CPPL_VERBOSE #ifdef CPPL_DEBUG if(vecA.L!=vecB.L){ std::cerr << "[ERROR] operator%(const zrovector&, const zrovector&)" << std::endl << "These two vectors can not make a dot product." << std::endl << "Your input was (" << vecA.L << ") % (" << vecB.L << ")." << std::endl; exit(1); } #endif//CPPL_DEBUG std::complex<double> val( zdotu_( vecA.L, vecA.Array, 1, vecB.Array, 1 ) ); return val; }
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ integer i__, j; doublereal xj, rec, tjj; integer jinc; doublereal xbnd; integer imax; doublereal tmax; doublecomplex tjjs; doublereal xmax, grow; doublereal tscal; doublecomplex uscal; integer jlast; doublecomplex csumj; logical upper; doublereal bignum; logical notran; integer jfirst; doublereal smlnum; logical nounit; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZLATRS solves one of the triangular systems */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ /* with scaling to prevent overflow. Here A is an upper or lower */ /* triangular matrix, A**T denotes the transpose of A, A**H denotes the */ /* conjugate transpose of A, x and b are n-element vectors, and s is a */ /* scaling factor, usually less than or equal to 1, chosen so that the */ /* components of x will be less than the overflow threshold. If the */ /* unscaled problem will not cause overflow, the Level 2 BLAS routine */ /* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ /* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Specifies the operation applied to A. */ /* = 'N': Solve A * x = s*b (No transpose) */ /* = 'T': Solve A**T * x = s*b (Transpose) */ /* = 'C': Solve A**H * x = s*b (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* NORMIN (input) CHARACTER*1 */ /* Specifies whether CNORM has been set or not. */ /* = 'Y': CNORM contains the column norms on entry */ /* = 'N': CNORM is not set on entry. On exit, the norms will */ /* be computed and stored in CNORM. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The triangular matrix A. If UPLO = 'U', the leading n by n */ /* upper triangular part of the array A contains the upper */ /* triangular matrix, and the strictly lower triangular part of */ /* A is not referenced. If UPLO = 'L', the leading n by n lower */ /* triangular part of the array A contains the lower triangular */ /* matrix, and the strictly upper triangular part of A is not */ /* referenced. If DIAG = 'U', the diagonal elements of A are */ /* also not referenced and are assumed to be 1. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max (1,N). */ /* X (input/output) COMPLEX*16 array, dimension (N) */ /* On entry, the right hand side b of the triangular system. */ /* On exit, X is overwritten by the solution vector x. */ /* SCALE (output) DOUBLE PRECISION */ /* The scaling factor s for the triangular system */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ /* If SCALE = 0, the matrix A is singular or badly scaled, and */ /* the vector x is an exact or approximate solution to A*x = 0. */ /* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ /* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ /* contains the norm of the off-diagonal part of the j-th column */ /* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ /* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ /* must be greater than or equal to the 1-norm. */ /* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ /* returns the 1-norm of the offdiagonal part of the j-th column */ /* of A. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -k, the k-th argument had an illegal value */ /* Further Details */ /* ======= ======= */ /* A rough bound on x is computed; if that is less than overflow, ZTRSV */ /* is called, otherwise, specific code is used which checks for possible */ /* overflow or divide-by-zero at every operation. */ /* A columnwise scheme is used for solving A*x = b. The basic algorithm */ /* if A is lower triangular is */ /* x[1:n] := b[1:n] */ /* x(j) := x(j) / A(j,j) */ /* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ /* end */ /* Define bounds on the components of x after j iterations of the loop: */ /* M(j) = bound on x[1:j] */ /* G(j) = bound on x[j+1:n] */ /* Then for iteration j+1 we have */ /* M(j+1) <= G(j) / | A(j+1,j+1) | */ /* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ /* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ /* where CNORM(j+1) is greater than or equal to the infinity-norm of */ /* column j+1 of A, not counting the diagonal. Hence */ /* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ /* 1<=i<=j */ /* and */ /* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ /* 1<=i< j */ /* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */ /* max(underflow, 1/overflow). */ /* The bound on x(j) is also used to determine when a step in the */ /* columnwise method can be performed without fear of overflow. If */ /* the computed bound is greater than a large constant, x is scaled to */ /* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ /* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ /* Similarly, a row-wise scheme is used to solve A**T *x = b or */ /* A**H *x = b. The basic algorithm for A upper triangular is */ /* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ /* end */ /* We simultaneously compute two bounds */ /* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ /* M(j) = bound on x(i), 1<=i<=j */ /* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ /* Then the bound on x(j) is */ /* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ /* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ /* 1<=i<=j */ /* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */ /* than max(underflow, 1/overflow). */ /* ===================================================================== */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --x; --cnorm; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); /* Test the input parameters. */ if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (! lsame_(normin, "Y") && ! lsame_(normin, "N")) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZLATRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine machine dependent parameters to control overflow. */ smlnum = dlamch_("Safe minimum"); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); smlnum /= dlamch_("Precision"); bignum = 1. / smlnum; *scale = 1.; if (lsame_(normin, "N")) { /* Compute the 1-norm of each column, not including the diagonal. */ if (upper) { /* A is upper triangular. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1); } } else { /* A is lower triangular. */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); } cnorm[*n] = 0.; } } /* Scale the column norms by TSCAL if the maximum element in CNORM is */ /* greater than BIGNUM/2. */ imax = idamax_(n, &cnorm[1], &c__1); tmax = cnorm[imax]; if (tmax <= bignum * .5) { tscal = 1.; } else { tscal = .5 / (smlnum * tmax); dscal_(n, &tscal, &cnorm[1], &c__1); } /* Compute a bound on the computed solution vector to see if the */ /* Level 2 BLAS routine ZTRSV can be used. */ xmax = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = j; d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = d_imag(&x[j]) / 2., abs(d__2)); xmax = max(d__3,d__4); } xbnd = xmax; if (notran) { /* Compute the growth in A * x = b. */ if (upper) { jfirst = *n; jlast = 1; jinc = -1; } else { jfirst = 1; jlast = *n; jinc = 1; } if (tscal != 1.) { grow = 0.; goto L60; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ grow = .5 / max(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L60; } i__3 = j + j * a_dim1; tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = G(j-1) / abs(A(j,j)) */ /* Computing MIN */ d__1 = xbnd, d__2 = min(1.,tjj) * grow; xbnd = min(d__1,d__2); } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } if (tjj + cnorm[j] >= smlnum) { /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ grow *= tjj / (tjj + cnorm[j]); } else { /* G(j) could overflow, set GROW to 0. */ grow = 0.; } } grow = xbnd; } else { /* A is unit triangular. */ /* Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L60; } /* G(j) = G(j-1)*( 1 + CNORM(j) ) */ grow *= 1. / (cnorm[j] + 1.); } } L60: ; } else { /* Compute the growth in A**T * x = b or A**H * x = b. */ if (upper) { jfirst = 1; jlast = *n; jinc = 1; } else { jfirst = *n; jlast = 1; jinc = -1; } if (tscal != 1.) { grow = 0.; goto L90; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ grow = .5 / max(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L90; } /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ xj = cnorm[j] + 1.; /* Computing MIN */ d__1 = grow, d__2 = xbnd / xj; grow = min(d__1,d__2); i__3 = j + j * a_dim1; tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ if (xj > tjj) { xbnd *= tjj / xj; } } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } } grow = min(grow,xbnd); } else { /* A is unit triangular. */ /* Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L90; } /* G(j) = ( 1 + CNORM(j) )*G(j-1) */ xj = cnorm[j] + 1.; grow /= xj; } } L90: ; } if (grow * tscal > smlnum) { /* Use the Level 2 BLAS solve if the reciprocal of the bound on */ /* elements of X is not too small. */ ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1); } else { /* Use a Level 1 BLAS solve, scaling intermediate results. */ if (xmax > bignum * .5) { /* Scale X so that its components are less than or equal to */ /* BIGNUM in absolute value. */ *scale = bignum * .5 / xmax; zdscal_(n, scale, &x[1], &c__1); xmax = bignum; } else { xmax *= 2.; } if (notran) { /* Solve A * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L110; } } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale x by 1/b(j). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ /* to avoid overflow when dividing by A(j,j). */ rec = tjj * bignum / xj; if (cnorm[j] > 1.) { /* Scale by 1/CNORM(j) to avoid overflow when */ /* multiplying x(j) times column j. */ rec /= cnorm[j]; } zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0, and compute a solution to A*x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; xj = 1.; *scale = 0.; xmax = 0.; } L110: /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j of A. */ if (xj > 1.) { rec = 1. / xj; if (cnorm[j] > (bignum - xmax) * rec) { /* Scale x by 1/(2*abs(x(j))). */ rec *= .5; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } else if (xj * cnorm[j] > bignum - xmax) { /* Scale x by 1/2. */ zdscal_(n, &c_b36, &x[1], &c__1); *scale *= .5; } if (upper) { if (j > 1) { /* Compute the update */ /* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ i__3 = j - 1; i__4 = j; z__2.r = -x[i__4].r, z__2.i = -x[i__4].i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); i__3 = j - 1; i__ = izamax_(&i__3, &x[1], &c__1); i__3 = i__; xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2)); } } else { if (j < *n) { /* Compute the update */ /* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ i__3 = *n - j; i__4 = j; z__2.r = -x[i__4].r, z__2.i = -x[i__4].i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); i__3 = *n - j; i__ = j + izamax_(&i__3, &x[j + 1], &c__1); i__3 = i__; xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2)); } } } } else if (lsame_(trans, "T")) { /* Solve A**T * x = b */ i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2*XMAX). */ rec *= .5; if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3] .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, */ /* call ZDOTU to perform the dot product. */ if (upper) { i__3 = j - 1; zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + j * a_dim1; z__3.r = a[i__4].r * uscal.r - a[i__4].i * uscal.i, z__3.i = a[i__4].r * uscal.i + a[ i__4].i * uscal.r; i__5 = i__; z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; } } else if (j < *n) { i__3 = *n; for (i__ = j + 1; i__ <= i__3; ++i__) { i__4 = i__ + j * a_dim1; z__3.r = a[i__4].r * uscal.r - a[i__4].i * uscal.i, z__3.i = a[i__4].r * uscal.i + a[ i__4].i * uscal.r; i__5 = i__; z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3] .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L160; } } /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/abs(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solution to A**T *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; *scale = 0.; xmax = 0.; } L160: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ /* product has already been divided by 1/A(j,j). */ i__3 = j; zladiv_(&z__2, &x[j], &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); xmax = max(d__3,d__4); } } else { /* Solve A**H * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2*XMAX). */ rec *= .5; if (nounit) { d_cnjg(&z__2, &a[j + j * a_dim1]); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, */ /* call ZDOTC to perform the dot product. */ if (upper) { i__3 = j - 1; zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i__ = 1; i__ <= i__3; ++i__) { d_cnjg(&z__4, &a[i__ + j * a_dim1]); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = i__; z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; } } else if (j < *n) { i__3 = *n; for (i__ = j + 1; i__ <= i__3; ++i__) { d_cnjg(&z__4, &a[i__ + j * a_dim1]); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = i__; z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); if (nounit) { d_cnjg(&z__2, &a[j + j * a_dim1]); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L210; } } /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/abs(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solution to A**H *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; *scale = 0.; xmax = 0.; } L210: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ /* product has already been divided by 1/A(j,j). */ i__3 = j; zladiv_(&z__2, &x[j], &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); xmax = max(d__3,d__4); } } *scale /= tscal; } /* Scale the column norms by 1/TSCAL for return. */ if (tscal != 1.) { d__1 = 1. / tscal; dscal_(n, &d__1, &cnorm[1], &c__1); } return 0; /* End of ZLATRS */ } /* zlatrs_ */
/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info) { /* System generated locals */ integer i__1, i__2, i__3; doublecomplex z__1, z__2, z__3; /* Local variables */ doublecomplex d__; integer j, k; doublecomplex t, ak; integer kc, kp, kx, kpc, npp; doublecomplex akp1, temp, akkp1; integer kstep; logical upper; integer kcnext; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZSPTRI computes the inverse of a complex symmetric indefinite matrix */ /* A in packed storage using the factorization A = U*D*U**T or */ /* A = L*D*L**T computed by ZSPTRF. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the details of the factorization are stored */ /* as an upper or lower triangular matrix. */ /* = 'U': Upper triangular, form is A = U*D*U**T; */ /* = 'L': Lower triangular, form is A = L*D*L**T. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* On entry, the block diagonal matrix D and the multipliers */ /* used to obtain the factor U or L as computed by ZSPTRF, */ /* stored as a packed triangular matrix. */ /* On exit, if INFO = 0, the (symmetric) inverse of the original */ /* matrix, stored as a packed triangular matrix. The j-th column */ /* of inv(A) is stored in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */ /* if UPLO = 'L', */ /* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */ /* IPIV (input) INTEGER array, dimension (N) */ /* Details of the interchanges and the block structure of D */ /* as determined by ZSPTRF. */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ /* inverse could not be computed. */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --work; --ipiv; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("ZSPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ kp = *n * (*n + 1) / 2; for (*info = *n; *info >= 1; --(*info)) { i__1 = kp; if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) { return 0; } kp -= *info; } } else { /* Lower triangular storage: examine D from top to bottom. */ kp = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = kp; if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) { return 0; } kp = kp + *n - *info + 1; } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U'. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ k = 1; kc = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } kcnext = kc + k; if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = kc + k - 1; z_div(&z__1, &c_b1, &ap[kc + k - 1]); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kc], &c__1); i__1 = kc + k - 1; i__2 = kc + k - 1; i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block */ /* Invert the diagonal block. */ i__1 = kcnext + k - 1; t.r = ap[i__1].r, t.i = ap[i__1].i; z_div(&z__1, &ap[kc + k - 1], &t); ak.r = z__1.r, ak.i = z__1.i; z_div(&z__1, &ap[kcnext + k], &t); akp1.r = z__1.r, akp1.i = z__1.i; z_div(&z__1, &ap[kcnext + k - 1], &t); akkp1.r = z__1.r, akkp1.i = z__1.i; z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i + ak.i * akp1.r; z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; d__.r = z__1.r, d__.i = z__1.i; i__1 = kc + k - 1; z_div(&z__1, &akp1, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kcnext + k; z_div(&z__1, &ak, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kcnext + k - 1; z__2.r = -akkp1.r, z__2.i = -akkp1.i; z_div(&z__1, &z__2, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kc], &c__1); i__1 = kc + k - 1; i__2 = kc + k - 1; i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kcnext + k - 1; i__2 = kcnext + k - 1; i__3 = k - 1; zdotu_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = k - 1; zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kcnext], &c__1); i__1 = kcnext + k; i__2 = kcnext + k; i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; } kstep = 2; kcnext = kcnext + k + 1; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the leading */ /* submatrix A(1:k+1,1:k+1) */ kpc = (kp - 1) * kp / 2 + 1; i__1 = kp - 1; zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1); kx = kpc + kp - 1; i__1 = k - 1; for (j = kp + 1; j <= i__1; ++j) { kx = kx + j - 1; i__2 = kc + j - 1; temp.r = ap[i__2].r, temp.i = ap[i__2].i; i__2 = kc + j - 1; i__3 = kx; ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; i__2 = kx; ap[i__2].r = temp.r, ap[i__2].i = temp.i; } i__1 = kc + k - 1; temp.r = ap[i__1].r, temp.i = ap[i__1].i; i__1 = kc + k - 1; i__2 = kpc + kp - 1; ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; i__1 = kpc + kp - 1; ap[i__1].r = temp.r, ap[i__1].i = temp.i; if (kstep == 2) { i__1 = kc + k + k - 1; temp.r = ap[i__1].r, temp.i = ap[i__1].i; i__1 = kc + k + k - 1; i__2 = kc + k + kp - 1; ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; i__1 = kc + k + kp - 1; ap[i__1].r = temp.r, ap[i__1].i = temp.i; } } k += kstep; kc = kcnext; goto L30; L50: ; } else { /* Compute inv(A) from the factorization A = L*D*L'. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ npp = *n * (*n + 1) / 2; k = *n; kc = npp; L60: /* If K < 1, exit from loop. */ if (k < 1) { goto L80; } kcnext = kc - (*n - k + 2); if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = kc; z_div(&z__1, &c_b1, &ap[kc]); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], & c__1, &c_b2, &ap[kc + 1], &c__1); i__1 = kc; i__2 = kc; i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block */ /* Invert the diagonal block. */ i__1 = kcnext + 1; t.r = ap[i__1].r, t.i = ap[i__1].i; z_div(&z__1, &ap[kcnext], &t); ak.r = z__1.r, ak.i = z__1.i; z_div(&z__1, &ap[kc], &t); akp1.r = z__1.r, akp1.i = z__1.i; z_div(&z__1, &ap[kcnext + 1], &t); akkp1.r = z__1.r, akkp1.i = z__1.i; z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i + ak.i * akp1.r; z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; d__.r = z__1.r, d__.i = z__1.i; i__1 = kcnext; z_div(&z__1, &akp1, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kc; z_div(&z__1, &ak, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kcnext + 1; z__2.r = -akkp1.r, z__2.i = -akkp1.i; z_div(&z__1, &z__2, &d__); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & c__1, &c_b2, &ap[kc + 1], &c__1); i__1 = kc; i__2 = kc; i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = kcnext + 1; i__2 = kcnext + 1; i__3 = *n - k; zdotu_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], & c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = *n - k; zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = -0.; zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & c__1, &c_b2, &ap[kcnext + 2], &c__1); i__1 = kcnext; i__2 = kcnext; i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1); z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; } kstep = 2; kcnext -= *n - k + 3; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the trailing */ /* submatrix A(k-1:n,k-1:n) */ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; if (kp < *n) { i__1 = *n - kp; zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & c__1); } kx = kc + kp - k; i__1 = kp - 1; for (j = k + 1; j <= i__1; ++j) { kx = kx + *n - j + 1; i__2 = kc + j - k; temp.r = ap[i__2].r, temp.i = ap[i__2].i; i__2 = kc + j - k; i__3 = kx; ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; i__2 = kx; ap[i__2].r = temp.r, ap[i__2].i = temp.i; } i__1 = kc; temp.r = ap[i__1].r, temp.i = ap[i__1].i; i__1 = kc; i__2 = kpc; ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; i__1 = kpc; ap[i__1].r = temp.r, ap[i__1].i = temp.i; if (kstep == 2) { i__1 = kc - *n + k - 1; temp.r = ap[i__1].r, temp.i = ap[i__1].i; i__1 = kc - *n + k - 1; i__2 = kc - *n + kp - 1; ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; i__1 = kc - *n + kp - 1; ap[i__1].r = temp.r, ap[i__1].i = temp.i; } } k -= kstep; kc = kcnext; goto L60; L80: ; } return 0; /* End of ZSPTRI */ } /* zsptri_ */
/* Subroutine */ int check2_(doublereal *sfac) { /* Initialized data */ static doublecomplex ca = {.4,-.7}; static integer incxs[4] = { 1,2,-2,-1 }; static integer incys[4] = { 1,-2,1,-2 }; static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; static integer ns[4] = { 0,1,2,4 }; static doublecomplex cx1[7] = { {.7,-.8},{-.4,-.7},{-.1,-.9},{.2,-.8},{ -.9,-.4 },{.1,.4},{-.6,.6} }; static doublecomplex cy1[7] = { {.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{ -.1, -.2 },{-.5,-.3},{.8,-.7} }; static doublecomplex ct8[112] /* was [7][4][4] */ = { {.6,-.6},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{ .03, -.89 },{-.38,-.96},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.} ,{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-.9,.5},{.42,-1.41},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{.78,.06},{-.9,.5},{.06,-.13},{.1,-.5} ,{-.77,-.49},{-.5,-.3},{.52,-1.51},{.6,-.6},{0.,0.},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{-.07,-.89},{-1.18,-.31},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{.78,.06},{-1.54,.97},{.03,-.89},{ -.18, -1.31 },{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{0.,0.} ,{0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{.1,-.5},{-.77,-.49} ,{-.5,-.3},{.32,-1.16} }; static doublecomplex ct7[16] /* was [4][4] */ = { {0.,0.},{ -.06, -.9 },{.65,-.47},{-.34,-1.22},{0.,0.},{-.06,-.9},{-.59,-1.46},{ -1.04,-.04 },{0.,0.},{-.06,-.9},{-.83,.59},{.07,-.37},{0.,0.},{ -.06,-.9 },{-.76,-1.15},{-1.33,-1.82} }; static doublecomplex ct6[16] /* was [4][4] */ = { {0.,0.},{.9,.06}, {.91,-.77},{1.8,-.1},{0.,0.},{.9,.06},{1.45,.74},{.2,.9},{0.,0.},{ .9,.06 },{-.55,.23},{.83,-.39},{0.,0.},{.9,.06},{1.04,.79},{ 1.95, 1.22 } }; static doublecomplex ct10x[112] /* was [7][4][4] */ = { {.7,-.8},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{ 0.,0. },{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{.7,-.6},{-.4,-.7},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.} ,{.8,-.7},{-.4,-.7},{-.1,-.2},{.2,-.8},{.7,-.6},{.1,.4},{.6,-.6},{ .7,-.8 },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.9,.5},{-.4,-.7}, {.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.1,-.5},{-.4,-.7},{.7, -.6 },{.2,-.8},{-.9,.5},{.1,.4},{.6,-.6},{.7,-.8},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{.6,-.6},{.7,-.6},{-.1,-.2},{.8,-.7},{0.,0.},{ 0., 0. },{0.,0.} }; static doublecomplex ct10y[112] /* was [7][4][4] */ = { {.6,-.6},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{-.1,-.9},{ .2, -.8 },{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ 0., 0. },{0.,0.},{-.1,-.9},{-.9,.5},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{ 0.,0. },{-.6,.6},{-.9,.5},{-.9,-.4},{.1,-.5},{-.1,-.9},{-.5,-.3},{ .7,-.8 },{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ .7,-.8 },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.1,-.9}, {.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.6,.6},{-.9, -.4 },{-.1,-.9},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{0.,0.} ,{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{.1,-.5},{ -.1,-.9 },{-.5,-.3},{.2,-.8} }; static doublecomplex csize1[4] = { {0.,0.},{.9,.9},{1.63,1.73},{2.9,2.78} }; static doublecomplex csize3[14] = { {0.,0.},{0.,0.},{0.,0.},{0.,0.},{ 0., 0. },{0.,0.},{0.,0.},{1.17,1.17},{1.17,1.17},{1.17,1.17},{ 1.17, 1.17 },{1.17,1.17},{1.17,1.17},{1.17,1.17} }; static doublecomplex csize2[14] /* was [7][2] */ = { {0.,0.},{0.,0.},{ 0.,0. },{0.,0.},{0.,0.},{0.,0.},{0.,0.},{1.54,1.54},{1.54,1.54},{ 1.54,1.54 },{1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54} }; /* System generated locals */ integer i__1, i__2; doublecomplex z__1; /* Builtin functions */ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_wsle(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ static doublecomplex cdot[1]; static integer lenx, leny, i__; extern /* Subroutine */ int ctest_(integer *, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer ksize; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); static integer ki, kn; static doublecomplex cx[7], cy[7]; static integer mx, my; /* Fortran I/O blocks */ static cilist io___48 = { 0, 6, 0, 0, 0 }; #define ct10x_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36 #define ct10x_ref(a_1,a_2,a_3) ct10x[ct10x_subscr(a_1,a_2,a_3)] #define ct10y_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36 #define ct10y_ref(a_1,a_2,a_3) ct10y[ct10y_subscr(a_1,a_2,a_3)] #define lens_ref(a_1,a_2) lens[(a_2)*4 + a_1 - 5] #define csize2_subscr(a_1,a_2) (a_2)*7 + a_1 - 8 #define csize2_ref(a_1,a_2) csize2[csize2_subscr(a_1,a_2)] #define ct6_subscr(a_1,a_2) (a_2)*4 + a_1 - 5 #define ct6_ref(a_1,a_2) ct6[ct6_subscr(a_1,a_2)] #define ct7_subscr(a_1,a_2) (a_2)*4 + a_1 - 5 #define ct7_ref(a_1,a_2) ct7[ct7_subscr(a_1,a_2)] #define ct8_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36 #define ct8_ref(a_1,a_2,a_3) ct8[ct8_subscr(a_1,a_2,a_3)] for (ki = 1; ki <= 4; ++ki) { combla_1.incx = incxs[ki - 1]; combla_1.incy = incys[ki - 1]; mx = abs(combla_1.incx); my = abs(combla_1.incy); for (kn = 1; kn <= 4; ++kn) { combla_1.n = ns[kn - 1]; ksize = min(2,kn); lenx = lens_ref(kn, mx); leny = lens_ref(kn, my); for (i__ = 1; i__ <= 7; ++i__) { i__1 = i__ - 1; i__2 = i__ - 1; cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i; i__1 = i__ - 1; i__2 = i__ - 1; cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i; /* L20: */ } if (combla_1.icase == 1) { zdotc_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, & combla_1.incy); cdot[0].r = z__1.r, cdot[0].i = z__1.i; ctest_(&c__1, cdot, &ct6_ref(kn, ki), &csize1[kn - 1], sfac); } else if (combla_1.icase == 2) { zdotu_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, & combla_1.incy); cdot[0].r = z__1.r, cdot[0].i = z__1.i; ctest_(&c__1, cdot, &ct7_ref(kn, ki), &csize1[kn - 1], sfac); } else if (combla_1.icase == 3) { zaxpy_(&combla_1.n, &ca, cx, &combla_1.incx, cy, & combla_1.incy); ctest_(&leny, cy, &ct8_ref(1, kn, ki), &csize2_ref(1, ksize), sfac); } else if (combla_1.icase == 4) { zcopy_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy); ctest_(&leny, cy, &ct10y_ref(1, kn, ki), csize3, &c_b43); } else if (combla_1.icase == 5) { zswap_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy); ctest_(&lenx, cx, &ct10x_ref(1, kn, ki), csize3, &c_b43); ctest_(&leny, cy, &ct10y_ref(1, kn, ki), csize3, &c_b43); } else { s_wsle(&io___48); do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen) 28); e_wsle(); s_stop("", (ftnlen)0); } /* L40: */ } /* L60: */ } return 0; } /* check2_ */
/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal * scale, doublereal *cnorm, integer *info) { /* -- 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 ======= ZLATPS solves one of the triangular systems A * x = s*b, A**T * x = s*b, or A**H * x = s*b, with scaling to prevent overflow, where A is an upper or lower triangular matrix stored in packed form. Here A**T denotes the transpose of A, A**H denotes the conjugate transpose of A, x and b are n-element vectors, and s is a scaling factor, usually less than or equal to 1, chosen so that the components of x will be less than the overflow threshold. If the unscaled problem will not cause overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), then s is set to 0 and a non-trivial solution to A*x = 0 is returned. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the matrix A is upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular TRANS (input) CHARACTER*1 Specifies the operation applied to A. = 'N': Solve A * x = s*b (No transpose) = 'T': Solve A**T * x = s*b (Transpose) = 'C': Solve A**H * x = s*b (Conjugate transpose) DIAG (input) CHARACTER*1 Specifies whether or not the matrix A is unit triangular. = 'N': Non-unit triangular = 'U': Unit triangular NORMIN (input) CHARACTER*1 Specifies whether CNORM has been set or not. = 'Y': CNORM contains the column norms on entry = 'N': CNORM is not set on entry. On exit, the norms will be computed and stored in CNORM. N (input) INTEGER The order of the matrix A. N >= 0. AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) The upper or lower triangular matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. X (input/output) COMPLEX*16 array, dimension (N) On entry, the right hand side b of the triangular system. On exit, X is overwritten by the solution vector x. SCALE (output) DOUBLE PRECISION The scaling factor s for the triangular system A * x = s*b, A**T * x = s*b, or A**H * x = s*b. If SCALE = 0, the matrix A is singular or badly scaled, and the vector x is an exact or approximate solution to A*x = 0. CNORM (input or output) DOUBLE PRECISION array, dimension (N) If NORMIN = 'Y', CNORM is an input argument and CNORM(j) contains the norm of the off-diagonal part of the j-th column of A. If TRANS = 'N', CNORM(j) must be greater than or equal to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) must be greater than or equal to the 1-norm. If NORMIN = 'N', CNORM is an output argument and CNORM(j) returns the 1-norm of the offdiagonal part of the j-th column of A. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -k, the k-th argument had an illegal value Further Details ======= ======= A rough bound on x is computed; if that is less than overflow, ZTPSV is called, otherwise, specific code is used which checks for possible overflow or divide-by-zero at every operation. A columnwise scheme is used for solving A*x = b. The basic algorithm if A is lower triangular is x[1:n] := b[1:n] for j = 1, ..., n x(j) := x(j) / A(j,j) x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] end Define bounds on the components of x after j iterations of the loop: M(j) = bound on x[1:j] G(j) = bound on x[j+1:n] Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. Then for iteration j+1 we have M(j+1) <= G(j) / | A(j+1,j+1) | G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) where CNORM(j+1) is greater than or equal to the infinity-norm of column j+1 of A, not counting the diagonal. Hence G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) 1<=i<=j and |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) 1<=i< j Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the reciprocal of the largest M(j), j=1,..,n, is larger than max(underflow, 1/overflow). The bound on x(j) is also used to determine when a step in the columnwise method can be performed without fear of overflow. If the computed bound is greater than a large constant, x is scaled to prevent overflow, but if the bound overflows, x is set to 0, x(j) to 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. Similarly, a row-wise scheme is used to solve A**T *x = b or A**H *x = b. The basic algorithm for A upper triangular is for j = 1, ..., n x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) end We simultaneously compute two bounds G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j M(j) = bound on x(i), 1<=i<=j The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. Then the bound on x(j) is M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) 1<=i<=j and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater than max(underflow, 1/overflow). ===================================================================== Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; static doublereal c_b36 = .5; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double d_imag(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static integer jinc, jlen; static doublereal xbnd; static integer imax; static doublereal tmax; static doublecomplex tjjs; static doublereal xmax, grow; static integer i, j; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); static doublereal tscal; static doublecomplex uscal; static integer jlast; static doublecomplex csumj; extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical upper; extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_( char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *); static integer ip; static doublereal xj; extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *); static doublereal bignum; extern integer izamax_(integer *, doublecomplex *, integer *); extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); static logical notran; static integer jfirst; extern doublereal dzasum_(integer *, doublecomplex *, integer *); static doublereal smlnum; static logical nounit; static doublereal rec, tjj; #define CNORM(I) cnorm[(I)-1] #define X(I) x[(I)-1] #define AP(I) ap[(I)-1] *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); /* Test the input parameters. */ if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (! lsame_(normin, "Y") && ! lsame_(normin, "N")) { *info = -4; } else if (*n < 0) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("ZLATPS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine machine dependent parameters to control overflow. */ smlnum = dlamch_("Safe minimum"); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); smlnum /= dlamch_("Precision"); bignum = 1. / smlnum; *scale = 1.; if (lsame_(normin, "N")) { /* Compute the 1-norm of each column, not including the diagona l. */ if (upper) { /* A is upper triangular. */ ip = 1; i__1 = *n; for (j = 1; j <= *n; ++j) { i__2 = j - 1; CNORM(j) = dzasum_(&i__2, &AP(ip), &c__1); ip += j; /* L10: */ } } else { /* A is lower triangular. */ ip = 1; i__1 = *n - 1; for (j = 1; j <= *n-1; ++j) { i__2 = *n - j; CNORM(j) = dzasum_(&i__2, &AP(ip + 1), &c__1); ip = ip + *n - j + 1; /* L20: */ } CNORM(*n) = 0.; } } /* Scale the column norms by TSCAL if the maximum element in CNORM is greater than BIGNUM/2. */ imax = idamax_(n, &CNORM(1), &c__1); tmax = CNORM(imax); if (tmax <= bignum * .5) { tscal = 1.; } else { tscal = .5 / (smlnum * tmax); dscal_(n, &tscal, &CNORM(1), &c__1); } /* Compute a bound on the computed solution vector to see if the Level 2 BLAS routine ZTPSV can be used. */ xmax = 0.; i__1 = *n; for (j = 1; j <= *n; ++j) { /* Computing MAX */ i__2 = j; d__3 = xmax, d__4 = (d__1 = X(j).r / 2., abs(d__1)) + (d__2 = d_imag(&X(j)) / 2., abs(d__2)); xmax = max(d__3,d__4); /* L30: */ } xbnd = xmax; if (notran) { /* Compute the growth in A * x = b. */ if (upper) { jfirst = *n; jlast = 1; jinc = -1; } else { jfirst = 1; jlast = *n; jinc = 1; } if (tscal != 1.) { grow = 0.; goto L60; } if (nounit) { /* A is non-unit triangular. Compute GROW = 1/G(j) and XBND = 1/M(j). Initially, G(0) = max{x(i), i=1,...,n}. */ grow = .5 / max(xbnd,smlnum); xbnd = grow; ip = jfirst * (jfirst + 1) / 2; jlen = *n; i__1 = jlast; i__2 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L60; } i__3 = ip; tjjs.r = AP(ip).r, tjjs.i = AP(ip).i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = G(j-1) / abs(A(j,j)) Computing MIN */ d__1 = xbnd, d__2 = min(1.,tjj) * grow; xbnd = min(d__1,d__2); } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } if (tjj + CNORM(j) >= smlnum) { /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j, j)) ) */ grow *= tjj / (tjj + CNORM(j)); } else { /* G(j) could overflow, set GROW to 0. */ grow = 0.; } ip += jinc * jlen; --jlen; /* L40: */ } grow = xbnd; } else { /* A is unit triangular. Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,... ,n}. Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L60; } /* G(j) = G(j-1)*( 1 + CNORM(j) ) */ grow *= 1. / (CNORM(j) + 1.); /* L50: */ } } L60: ; } else { /* Compute the growth in A**T * x = b or A**H * x = b. */ if (upper) { jfirst = 1; jlast = *n; jinc = 1; } else { jfirst = *n; jlast = 1; jinc = -1; } if (tscal != 1.) { grow = 0.; goto L90; } if (nounit) { /* A is non-unit triangular. Compute GROW = 1/G(j) and XBND = 1/M(j). Initially, M(0) = max{x(i), i=1,...,n}. */ grow = .5 / max(xbnd,smlnum); xbnd = grow; ip = jfirst * (jfirst + 1) / 2; jlen = 1; i__1 = jlast; i__2 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L90; } /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ xj = CNORM(j) + 1.; /* Computing MIN */ d__1 = grow, d__2 = xbnd / xj; grow = min(d__1,d__2); i__3 = ip; tjjs.r = AP(ip).r, tjjs.i = AP(ip).i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A( j,j)) */ if (xj > tjj) { xbnd *= tjj / xj; } } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } ++jlen; ip += jinc * jlen; /* L70: */ } grow = min(grow,xbnd); } else { /* A is unit triangular. Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,... ,n}. Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L90; } /* G(j) = ( 1 + CNORM(j) )*G(j-1) */ xj = CNORM(j) + 1.; grow /= xj; /* L80: */ } } L90: ; } if (grow * tscal > smlnum) { /* Use the Level 2 BLAS solve if the reciprocal of the bound on elements of X is not too small. */ ztpsv_(uplo, trans, diag, n, &AP(1), &X(1), &c__1); } else { /* Use a Level 1 BLAS solve, scaling intermediate results. */ if (xmax > bignum * .5) { /* Scale X so that its components are less than or equal to BIGNUM in absolute value. */ *scale = bignum * .5 / xmax; zdscal_(n, scale, &X(1), &c__1); xmax = bignum; } else { xmax *= 2.; } if (notran) { /* Solve A * x = b */ ip = jfirst * (jfirst + 1) / 2; i__1 = jlast; i__2 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Compute x(j) = b(j) / A(j,j), scaling x if nec essary. */ i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)), abs(d__2)); if (nounit) { i__3 = ip; z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip).i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L110; } } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale x by 1/b(j). */ rec = 1. / xj; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)) , abs(d__2)); } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs( A(j,j))*BIGNUM to avoid overflow when dividi ng by A(j,j). */ rec = tjj * bignum / xj; if (CNORM(j) > 1.) { /* Scale by 1/CNORM(j) to avoid overflow when multiplying x(j) times column j. */ rec /= CNORM(j); } zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)) , abs(d__2)); } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and scale = 0, and compute a solution to A*x = 0. */ i__3 = *n; for (i = 1; i <= *n; ++i) { i__4 = i; X(i).r = 0., X(i).i = 0.; /* L100: */ } i__3 = j; X(j).r = 1., X(j).i = 0.; xj = 1.; *scale = 0.; xmax = 0.; } L110: /* Scale x if necessary to avoid overflow when ad ding a multiple of column j of A. */ if (xj > 1.) { rec = 1. / xj; if (CNORM(j) > (bignum - xmax) * rec) { /* Scale x by 1/(2*abs(x(j))). */ rec *= .5; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; } } else if (xj * CNORM(j) > bignum - xmax) { /* Scale x by 1/2. */ zdscal_(n, &c_b36, &X(1), &c__1); *scale *= .5; } if (upper) { if (j > 1) { /* Compute the update x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ i__3 = j - 1; i__4 = j; z__2.r = -X(j).r, z__2.i = -X(j).i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &AP(ip - j + 1), &c__1, &X(1), & c__1); i__3 = j - 1; i = izamax_(&i__3, &X(1), &c__1); i__3 = i; xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag( &X(i)), abs(d__2)); } ip -= j; } else { if (j < *n) { /* Compute the update x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ i__3 = *n - j; i__4 = j; z__2.r = -X(j).r, z__2.i = -X(j).i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &AP(ip + 1), &c__1, &X(j + 1), & c__1); i__3 = *n - j; i = j + izamax_(&i__3, &X(j + 1), &c__1); i__3 = i; xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag( &X(i)), abs(d__2)); } ip = ip + *n - j + 1; } /* L120: */ } } else if (lsame_(trans, "T")) { /* Solve A**T * x = b */ ip = jfirst * (jfirst + 1) / 2; jlen = 1; i__2 = jlast; i__1 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). k<>j */ i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (CNORM(j) > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2 *XMAX). */ rec *= .5; if (nounit) { i__3 = ip; z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip) .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, call ZDOTU to perform the dot product. */ if (upper) { i__3 = j - 1; zdotu_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), & c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotu_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), & c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i = 1; i <= j-1; ++i) { i__4 = ip - j + i; z__3.r = AP(ip-j+i).r * uscal.r - AP(ip-j+i).i * uscal.i, z__3.i = AP(ip-j+i).r * uscal.i + AP(ip-j+i).i * uscal.r; i__5 = i; z__2.r = z__3.r * X(i).r - z__3.i * X(i).i, z__2.i = z__3.r * X(i).i + z__3.i * X( i).r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L130: */ } } else if (j < *n) { i__3 = *n - j; for (i = 1; i <= *n-j; ++i) { i__4 = ip + i; z__3.r = AP(ip+i).r * uscal.r - AP(ip+i).i * uscal.i, z__3.i = AP(ip+i).r * uscal.i + AP(ip+i).i * uscal.r; i__5 = j + i; z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i, z__2.i = z__3.r * X(j+i).i + z__3.i * X( j+i).r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L140: */ } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j, j) if 1/A(j,j) was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = X(j).r - csumj.r, z__1.i = X(j).i - csumj.i; X(j).r = z__1.r, X(j).i = z__1.i; i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)) , abs(d__2)); if (nounit) { /* Compute x(j) = x(j) / A(j,j), sc aling if necessary. */ i__3 = ip; z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip) .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L160; } } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/ab s(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j) ))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and scale = 0 and compute a solut ion to A**T *x = 0. */ i__3 = *n; for (i = 1; i <= *n; ++i) { i__4 = i; X(i).r = 0., X(i).i = 0.; /* L150: */ } i__3 = j; X(j).r = 1., X(j).i = 0.; *scale = 0.; xmax = 0.; } L160: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ i f the dot product has already been divided by 1/A (j,j). */ i__3 = j; zladiv_(&z__2, &X(j), &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; X(j).r = z__1.r, X(j).i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)), abs(d__2)); xmax = max(d__3,d__4); ++jlen; ip += jinc * jlen; /* L170: */ } } else { /* Solve A**H * x = b */ ip = jfirst * (jfirst + 1) / 2; jlen = 1; i__1 = jlast; i__2 = jinc; for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). k<>j */ i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (CNORM(j) > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2 *XMAX). */ rec *= .5; if (nounit) { d_cnjg(&z__2, &AP(ip)); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, call ZDOTC to perform the dot product. */ if (upper) { i__3 = j - 1; zdotc_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), & c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotc_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), & c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i = 1; i <= j-1; ++i) { d_cnjg(&z__4, &AP(ip - j + i)); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = i; z__2.r = z__3.r * X(i).r - z__3.i * X(i).i, z__2.i = z__3.r * X(i).i + z__3.i * X( i).r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L180: */ } } else if (j < *n) { i__3 = *n - j; for (i = 1; i <= *n-j; ++i) { d_cnjg(&z__4, &AP(ip + i)); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = j + i; z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i, z__2.i = z__3.r * X(j+i).i + z__3.i * X( j+i).r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L190: */ } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j, j) if 1/A(j,j) was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = X(j).r - csumj.r, z__1.i = X(j).i - csumj.i; X(j).r = z__1.r, X(j).i = z__1.i; i__3 = j; xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)) , abs(d__2)); if (nounit) { /* Compute x(j) = x(j) / A(j,j), sc aling if necessary. */ d_cnjg(&z__2, &AP(ip)); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L210; } } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/ab s(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j) ))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &X(1), &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &X(j), &tjjs); X(j).r = z__1.r, X(j).i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and scale = 0 and compute a solut ion to A**H *x = 0. */ i__3 = *n; for (i = 1; i <= *n; ++i) { i__4 = i; X(i).r = 0., X(i).i = 0.; /* L200: */ } i__3 = j; X(j).r = 1., X(j).i = 0.; *scale = 0.; xmax = 0.; } L210: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ i f the dot product has already been divided by 1/A (j,j). */ i__3 = j; zladiv_(&z__2, &X(j), &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; X(j).r = z__1.r, X(j).i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)), abs(d__2)); xmax = max(d__3,d__4); ++jlen; ip += jinc * jlen; /* L220: */ } } *scale /= tscal; } /* Scale the column norms by 1/TSCAL for return. */ if (tscal != 1.) { d__1 = 1. / tscal; dscal_(n, &d__1, &CNORM(1), &c__1); } return 0; /* End of ZLATPS */ } /* zlatps_ */
/* Subroutine */ int zget01_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *afac, integer *ldafac, integer *ipiv, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1, z__2; /* Local variables */ integer i__, j, k; doublecomplex t; doublereal eps, anorm; extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *, integer *, integer *, integer *, integer *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGET01 reconstructs a matrix A from its L*U factorization and */ /* computes the residual */ /* norm(L*U - A) / ( N * norm(A) * EPS ), */ /* where EPS is the machine epsilon. */ /* Arguments */ /* ========== */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The original M x N matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* AFAC (input/output) COMPLEX*16 array, dimension (LDAFAC,N) */ /* The factored form of the matrix A. AFAC contains the factors */ /* L and U from the L*U factorization as computed by ZGETRF. */ /* Overwritten with the reconstructed matrix, and then with the */ /* difference L*U - A. */ /* LDAFAC (input) INTEGER */ /* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices from ZGETRF. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */ /* RESID (output) DOUBLE PRECISION */ /* norm(L*U - A) / ( N * norm(A) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if M = 0 or N = 0. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; afac_dim1 = *ldafac; afac_offset = 1 + afac_dim1; afac -= afac_offset; --ipiv; --rwork; /* Function Body */ if (*m <= 0 || *n <= 0) { *resid = 0.; return 0; } /* Determine EPS and the norm of A. */ eps = dlamch_("Epsilon"); anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]); /* Compute the product L*U and overwrite AFAC with the result. */ /* A column at a time of the product is obtained, starting with */ /* column N. */ for (k = *n; k >= 1; --k) { if (k > *m) { ztrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset], ldafac, &afac[k * afac_dim1 + 1], &c__1); } else { /* Compute elements (K+1:M,K) */ i__1 = k + k * afac_dim1; t.r = afac[i__1].r, t.i = afac[i__1].i; if (k + 1 <= *m) { i__1 = *m - k; zscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1); i__1 = *m - k; i__2 = k - 1; zgemv_("No transpose", &i__1, &i__2, &c_b1, &afac[k + 1 + afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, & c_b1, &afac[k + 1 + k * afac_dim1], &c__1) ; } /* Compute the (K,K) element */ i__1 = k + k * afac_dim1; i__2 = k - 1; zdotu_(&z__2, &i__2, &afac[k + afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1); z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i; afac[i__1].r = z__1.r, afac[i__1].i = z__1.i; /* Compute elements (1:K-1,K) */ i__1 = k - 1; ztrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset], ldafac, &afac[k * afac_dim1 + 1], &c__1); } /* L10: */ } i__1 = min(*m,*n); zlaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1); /* Compute the difference L*U - A and store in AFAC. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * afac_dim1; i__4 = i__ + j * afac_dim1; i__5 = i__ + j * a_dim1; z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[i__5] .i; afac[i__3].r = z__1.r, afac[i__3].i = z__1.i; /* L20: */ } /* L30: */ } /* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */ *resid = zlange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]); if (anorm <= 0.) { if (*resid != 0.) { *resid = 1. / eps; } } else { *resid = *resid / (doublereal) (*n) / anorm / eps; } return 0; /* End of ZGET01 */ } /* zget01_ */
/* Subroutine */ int zsytri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZSYTRI computes the inverse of a complex symmetric indefinite matrix A using the factorization A = U*D*U**T or A = L*D*L**T computed by ZSYTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**T; = 'L': Lower triangular, form is A = L*D*L**T. N (input) INTEGER The order of the matrix A. N >= 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by ZSYTRF. On exit, if INFO = 0, the (symmetric) inverse of the original matrix. If UPLO = 'U', the upper triangular part of the inverse is formed and the part of A below the diagonal is not referenced; if UPLO = 'L' the lower triangular part of the inverse is formed and the part of A above the diagonal is not referenced. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by ZSYTRF. WORK (workspace) COMPLEX*16 array, dimension (2*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; static doublecomplex c_b2 = {0.,0.}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1, z__2, z__3; /* Builtin functions */ void z_div(doublecomplex *, doublecomplex *, doublecomplex *); /* Local variables */ static doublecomplex temp, akkp1, d__; static integer k; static doublecomplex t; extern logical lsame_(char *, char *); static integer kstep; static logical upper; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zsymv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static doublecomplex ak; static integer kp; extern /* Subroutine */ int xerbla_(char *, integer *); static doublecomplex akp1; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --ipiv; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZSYTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ for (*info = *n; *info >= 1; --(*info)) { i__1 = a_subscr(*info, *info); if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) { return 0; } /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = a_subscr(*info, *info); if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) { return 0; } /* L20: */ } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L40; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k); z_div(&z__1, &c_b1, &a_ref(k, k)); a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; zcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1); z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k + 1); t.r = a[i__1].r, t.i = a[i__1].i; z_div(&z__1, &a_ref(k, k), &t); ak.r = z__1.r, ak.i = z__1.i; z_div(&z__1, &a_ref(k + 1, k + 1), &t); akp1.r = z__1.r, akp1.i = z__1.i; z_div(&z__1, &a_ref(k, k + 1), &t); akkp1.r = z__1.r, akkp1.i = z__1.i; z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i + ak.i * akp1.r; z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; d__.r = z__1.r, d__.i = z__1.i; i__1 = a_subscr(k, k); z_div(&z__1, &akp1, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k + 1, k + 1); z_div(&z__1, &ak, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k, k + 1); z__2.r = -akkp1.r, z__2.i = -akkp1.i; z_div(&z__1, &z__2, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; zcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1); z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k, k + 1); i__2 = a_subscr(k, k + 1); i__3 = k - 1; zdotu_(&z__2, &i__3, &a_ref(1, k), &c__1, &a_ref(1, k + 1), & c__1); z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = k - 1; zcopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1); i__1 = k - 1; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k + 1), &c__1); i__1 = a_subscr(k + 1, k + 1); i__2 = a_subscr(k + 1, k + 1); i__3 = k - 1; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k + 1), &c__1) ; z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; } kstep = 2; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the leading submatrix A(1:k+1,1:k+1) */ i__1 = kp - 1; zswap_(&i__1, &a_ref(1, k), &c__1, &a_ref(1, kp), &c__1); i__1 = k - kp - 1; zswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda); i__1 = a_subscr(k, k); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k); i__2 = a_subscr(kp, kp); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, kp); a[i__1].r = temp.r, a[i__1].i = temp.i; if (kstep == 2) { i__1 = a_subscr(k, k + 1); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k + 1); i__2 = a_subscr(kp, k + 1); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, k + 1); a[i__1].r = temp.r, a[i__1].i = temp.i; } } k += kstep; goto L30; L40: ; } else { /* Compute inv(A) from the factorization A = L*D*L'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = *n; L50: /* If K < 1, exit from loop. */ if (k < 1) { goto L60; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k); z_div(&z__1, &c_b1, &a_ref(k, k)); a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1) ; z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k - 1); t.r = a[i__1].r, t.i = a[i__1].i; z_div(&z__1, &a_ref(k - 1, k - 1), &t); ak.r = z__1.r, ak.i = z__1.i; z_div(&z__1, &a_ref(k, k), &t); akp1.r = z__1.r, akp1.i = z__1.i; z_div(&z__1, &a_ref(k, k - 1), &t); akkp1.r = z__1.r, akkp1.i = z__1.i; z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i + ak.i * akp1.r; z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; d__.r = z__1.r, d__.i = z__1.i; i__1 = a_subscr(k - 1, k - 1); z_div(&z__1, &akp1, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k, k); z_div(&z__1, &ak, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k, k - 1); z__2.r = -akkp1.r, z__2.i = -akkp1.i; z_div(&z__1, &z__2, &d__); a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1) ; z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = a_subscr(k, k - 1); i__2 = a_subscr(k, k - 1); i__3 = *n - k; zdotu_(&z__2, &i__3, &a_ref(k + 1, k), &c__1, &a_ref(k + 1, k - 1), &c__1); z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = *n - k; zcopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1); i__1 = *n - k; z__1.r = -1., z__1.i = 0.; zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k - 1), &c__1); i__1 = a_subscr(k - 1, k - 1); i__2 = a_subscr(k - 1, k - 1); i__3 = *n - k; zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k - 1), & c__1); z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; } kstep = 2; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the trailing submatrix A(k-1:n,k-1:n) */ if (kp < *n) { i__1 = *n - kp; zswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), & c__1); } i__1 = kp - k - 1; zswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda); i__1 = a_subscr(k, k); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k); i__2 = a_subscr(kp, kp); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, kp); a[i__1].r = temp.r, a[i__1].i = temp.i; if (kstep == 2) { i__1 = a_subscr(k, k - 1); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k - 1); i__2 = a_subscr(kp, k - 1); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, k - 1); a[i__1].r = temp.r, a[i__1].i = temp.i; } } k -= kstep; goto L50; L60: ; } return 0; /* End of ZSYTRI */ } /* zsytri_ */
/* Subroutine */ int ztrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *c__, integer *ldc, doublereal *scale, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double d_imag(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ integer j, k, l; doublecomplex a11; doublereal db; doublecomplex x11; doublereal da11; doublecomplex vec; doublereal dum[1], eps, sgn, smin; doublecomplex suml, sumr; extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zdotu_( doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *); doublereal scaloc; extern /* Subroutine */ int xerbla_(char *, integer *); extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); doublereal bignum; extern /* Subroutine */ int zdscal_(integer *, doublereal *, doublecomplex *, integer *); extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); logical notrna, notrnb; doublereal smlnum; /* -- LAPACK routine (version 3.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZTRSYL solves the complex Sylvester matrix equation: */ /* op(A)*X + X*op(B) = scale*C or */ /* op(A)*X - X*op(B) = scale*C, */ /* where op(A) = A or A**H, and A and B are both upper triangular. A is */ /* M-by-M and B is N-by-N; the right hand side C and the solution X are */ /* M-by-N; and scale is an output scale factor, set <= 1 to avoid */ /* overflow in X. */ /* Arguments */ /* ========= */ /* TRANA (input) CHARACTER*1 */ /* Specifies the option op(A): */ /* = 'N': op(A) = A (No transpose) */ /* = 'C': op(A) = A**H (Conjugate transpose) */ /* TRANB (input) CHARACTER*1 */ /* Specifies the option op(B): */ /* = 'N': op(B) = B (No transpose) */ /* = 'C': op(B) = B**H (Conjugate transpose) */ /* ISGN (input) INTEGER */ /* Specifies the sign in the equation: */ /* = +1: solve op(A)*X + X*op(B) = scale*C */ /* = -1: solve op(A)*X - X*op(B) = scale*C */ /* M (input) INTEGER */ /* The order of the matrix A, and the number of rows in the */ /* matrices X and C. M >= 0. */ /* N (input) INTEGER */ /* The order of the matrix B, and the number of columns in the */ /* matrices X and C. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,M) */ /* The upper triangular matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* B (input) COMPLEX*16 array, dimension (LDB,N) */ /* The upper triangular matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* C (input/output) COMPLEX*16 array, dimension (LDC,N) */ /* On entry, the M-by-N right hand side matrix C. */ /* On exit, C is overwritten by the solution matrix X. */ /* LDC (input) INTEGER */ /* The leading dimension of the array C. LDC >= max(1,M) */ /* SCALE (output) DOUBLE PRECISION */ /* The scale factor, scale, set <= 1 to avoid overflow in X. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* = 1: A and B have common or very close eigenvalues; perturbed */ /* values were used to solve the equation (but the matrices */ /* A and B are unchanged). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and Test input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1; c__ -= c_offset; /* Function Body */ notrna = lsame_(trana, "N"); notrnb = lsame_(tranb, "N"); *info = 0; if (! notrna && ! lsame_(trana, "C")) { *info = -1; } else if (! notrnb && ! lsame_(tranb, "C")) { *info = -2; } else if (*isgn != 1 && *isgn != -1) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*m)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldc < max(1,*m)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTRSYL", &i__1); return 0; } /* Quick return if possible */ *scale = 1.; if (*m == 0 || *n == 0) { return 0; } /* Set constants to control overflow */ eps = dlamch_("P"); smlnum = dlamch_("S"); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); smlnum = smlnum * (doublereal) (*m * *n) / eps; bignum = 1. / smlnum; /* Computing MAX */ d__1 = smlnum, d__2 = eps * zlange_("M", m, m, &a[a_offset], lda, dum), d__1 = max(d__1,d__2), d__2 = eps * zlange_("M", n, n, &b[b_offset], ldb, dum); smin = max(d__1,d__2); sgn = (doublereal) (*isgn); if (notrna && notrnb) { /* Solve A*X + ISGN*X*B = scale*C. */ /* The (K,L)th block of X is determined starting from */ /* bottom-left corner column by column by */ /* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ /* Where */ /* M L-1 */ /* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */ /* I=K+1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { for (k = *m; k >= 1; --k) { i__2 = *m - k; /* Computing MIN */ i__3 = k + 1; /* Computing MIN */ i__4 = k + 1; zdotu_(&z__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[ min(i__4, *m)+ l * c_dim1], &c__1); suml.r = z__1.r, suml.i = z__1.i; i__2 = l - 1; zdotu_(&z__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] , &c__1); sumr.r = z__1.r, sumr.i = z__1.i; i__2 = k + l * c_dim1; z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i; z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i; vec.r = z__1.r, vec.i = z__1.i; scaloc = 1.; i__2 = k + k * a_dim1; i__3 = l + l * b_dim1; z__2.r = sgn * b[i__3].r, z__2.i = sgn * b[i__3].i; z__1.r = a[i__2].r + z__2.r, z__1.i = a[i__2].i + z__2.i; a11.r = z__1.r, a11.i = z__1.i; da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( d__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.; da11 = smin; *info = 1; } db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( d__2)); if (da11 < 1. && db > 1.) { if (db > bignum * da11) { scaloc = 1. / db; } } z__3.r = scaloc, z__3.i = 0.; z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * z__3.i + vec.i * z__3.r; zladiv_(&z__1, &z__2, &a11); x11.r = z__1.r, x11.i = z__1.i; if (scaloc != 1.) { i__2 = *n; for (j = 1; j <= i__2; ++j) { zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); /* L10: */ } *scale *= scaloc; } i__2 = k + l * c_dim1; c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L20: */ } /* L30: */ } } else if (! notrna && notrnb) { /* Solve A' *X + ISGN*X*B = scale*C. */ /* The (K,L)th block of X is determined starting from */ /* upper-left corner column by column by */ /* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ /* Where */ /* K-1 L-1 */ /* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */ /* I=1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { i__2 = *m; for (k = 1; k <= i__2; ++k) { i__3 = k - 1; zdotc_(&z__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l * c_dim1 + 1], &c__1); suml.r = z__1.r, suml.i = z__1.i; i__3 = l - 1; zdotu_(&z__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] , &c__1); sumr.r = z__1.r, sumr.i = z__1.i; i__3 = k + l * c_dim1; z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i; z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; vec.r = z__1.r, vec.i = z__1.i; scaloc = 1.; d_cnjg(&z__2, &a[k + k * a_dim1]); i__3 = l + l * b_dim1; z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a11.r = z__1.r, a11.i = z__1.i; da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( d__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.; da11 = smin; *info = 1; } db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( d__2)); if (da11 < 1. && db > 1.) { if (db > bignum * da11) { scaloc = 1. / db; } } z__3.r = scaloc, z__3.i = 0.; z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * z__3.i + vec.i * z__3.r; zladiv_(&z__1, &z__2, &a11); x11.r = z__1.r, x11.i = z__1.i; if (scaloc != 1.) { i__3 = *n; for (j = 1; j <= i__3; ++j) { zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); /* L40: */ } *scale *= scaloc; } i__3 = k + l * c_dim1; c__[i__3].r = x11.r, c__[i__3].i = x11.i; /* L50: */ } /* L60: */ } } else if (! notrna && ! notrnb) { /* Solve A'*X + ISGN*X*B' = C. */ /* The (K,L)th block of X is determined starting from */ /* upper-right corner column by column by */ /* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */ /* Where */ /* K-1 */ /* R(K,L) = SUM [A'(I,K)*X(I,L)] + */ /* I=1 */ /* N */ /* ISGN*SUM [X(K,J)*B'(L,J)]. */ /* J=L+1 */ for (l = *n; l >= 1; --l) { i__1 = *m; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; zdotc_(&z__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l * c_dim1 + 1], &c__1); suml.r = z__1.r, suml.i = z__1.i; i__2 = *n - l; /* Computing MIN */ i__3 = l + 1; /* Computing MIN */ i__4 = l + 1; zdotc_(&z__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[ l + min(i__4, *n)* b_dim1], ldb); sumr.r = z__1.r, sumr.i = z__1.i; i__2 = k + l * c_dim1; d_cnjg(&z__4, &sumr); z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i; z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i; vec.r = z__1.r, vec.i = z__1.i; scaloc = 1.; i__2 = k + k * a_dim1; i__3 = l + l * b_dim1; z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i; z__2.r = a[i__2].r + z__3.r, z__2.i = a[i__2].i + z__3.i; d_cnjg(&z__1, &z__2); a11.r = z__1.r, a11.i = z__1.i; da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( d__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.; da11 = smin; *info = 1; } db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( d__2)); if (da11 < 1. && db > 1.) { if (db > bignum * da11) { scaloc = 1. / db; } } z__3.r = scaloc, z__3.i = 0.; z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * z__3.i + vec.i * z__3.r; zladiv_(&z__1, &z__2, &a11); x11.r = z__1.r, x11.i = z__1.i; if (scaloc != 1.) { i__2 = *n; for (j = 1; j <= i__2; ++j) { zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); /* L70: */ } *scale *= scaloc; } i__2 = k + l * c_dim1; c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L80: */ } /* L90: */ } } else if (notrna && ! notrnb) { /* Solve A*X + ISGN*X*B' = C. */ /* The (K,L)th block of X is determined starting from */ /* bottom-left corner column by column by */ /* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */ /* Where */ /* M N */ /* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] */ /* I=K+1 J=L+1 */ for (l = *n; l >= 1; --l) { for (k = *m; k >= 1; --k) { i__1 = *m - k; /* Computing MIN */ i__2 = k + 1; /* Computing MIN */ i__3 = k + 1; zdotu_(&z__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[ min(i__3, *m)+ l * c_dim1], &c__1); suml.r = z__1.r, suml.i = z__1.i; i__1 = *n - l; /* Computing MIN */ i__2 = l + 1; /* Computing MIN */ i__3 = l + 1; zdotc_(&z__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[ l + min(i__3, *n)* b_dim1], ldb); sumr.r = z__1.r, sumr.i = z__1.i; i__1 = k + l * c_dim1; d_cnjg(&z__4, &sumr); z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i; z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; z__1.r = c__[i__1].r - z__2.r, z__1.i = c__[i__1].i - z__2.i; vec.r = z__1.r, vec.i = z__1.i; scaloc = 1.; i__1 = k + k * a_dim1; d_cnjg(&z__3, &b[l + l * b_dim1]); z__2.r = sgn * z__3.r, z__2.i = sgn * z__3.i; z__1.r = a[i__1].r + z__2.r, z__1.i = a[i__1].i + z__2.i; a11.r = z__1.r, a11.i = z__1.i; da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( d__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.; da11 = smin; *info = 1; } db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( d__2)); if (da11 < 1. && db > 1.) { if (db > bignum * da11) { scaloc = 1. / db; } } z__3.r = scaloc, z__3.i = 0.; z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * z__3.i + vec.i * z__3.r; zladiv_(&z__1, &z__2, &a11); x11.r = z__1.r, x11.i = z__1.i; if (scaloc != 1.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); /* L100: */ } *scale *= scaloc; } i__1 = k + l * c_dim1; c__[i__1].r = x11.r, c__[i__1].i = x11.i; /* L110: */ } /* L120: */ } } return 0; /* End of ZTRSYL */ } /* ztrsyl_ */