From 1e8b2ad5a07fd32e63b55d7d52e1264829b96bb4 Mon Sep 17 00:00:00 2001 From: Axel Kohlmeyer Date: Wed, 28 Dec 2022 13:47:11 -0500 Subject: [PATCH] whitespace fixes --- lib/linalg/dasum.cpp | 68 +- lib/linalg/daxpy.cpp | 88 +- lib/linalg/dbdsqr.cpp | 796 ++++---- lib/linalg/dcabs1.cpp | 16 +- lib/linalg/dcopy.cpp | 92 +- lib/linalg/ddot.cpp | 86 +- lib/linalg/dgebd2.cpp | 174 +- lib/linalg/dgebrd.cpp | 166 +- lib/linalg/dgecon.cpp | 112 +- lib/linalg/dgelq2.cpp | 68 +- lib/linalg/dgelqf.cpp | 140 +- lib/linalg/dgelsd.cpp | 586 +++--- lib/linalg/dgelss.cpp | 906 ++++----- lib/linalg/dgemm.cpp | 266 +-- lib/linalg/dgemv.cpp | 216 +-- lib/linalg/dgeqr2.cpp | 68 +- lib/linalg/dgeqrf.cpp | 156 +- lib/linalg/dger.cpp | 100 +- lib/linalg/dgesv.cpp | 46 +- lib/linalg/dgesvd.cpp | 4106 ++++++++++++++++++++-------------------- lib/linalg/dgetf2.cpp | 100 +- lib/linalg/dgetrf.cpp | 136 +- lib/linalg/dgetrf2.cpp | 158 +- lib/linalg/dgetri.cpp | 172 +- lib/linalg/dgetrs.cpp | 80 +- lib/linalg/dlabad.cpp | 20 +- lib/linalg/dlabrd.cpp | 392 ++-- lib/linalg/dlacn2.cpp | 112 +- lib/linalg/dlacpy.cpp | 60 +- lib/linalg/dladiv.cpp | 80 +- lib/linalg/dlae2.cpp | 50 +- lib/linalg/dlaed0.cpp | 336 ++-- lib/linalg/dlaed1.cpp | 102 +- lib/linalg/dlaed2.cpp | 294 +-- lib/linalg/dlaed3.cpp | 148 +- lib/linalg/dlaed4.cpp | 1150 +++++------ lib/linalg/dlaed5.cpp | 92 +- lib/linalg/dlaed6.cpp | 312 +-- lib/linalg/dlaed7.cpp | 148 +- lib/linalg/dlaed8.cpp | 276 +-- lib/linalg/dlaed9.cpp | 118 +- lib/linalg/dlaeda.cpp | 158 +- lib/linalg/dlaev2.cpp | 92 +- lib/linalg/dlals0.cpp | 354 ++-- lib/linalg/dlalsa.cpp | 274 +-- lib/linalg/dlalsd.cpp | 436 ++--- lib/linalg/dlamrg.cpp | 78 +- lib/linalg/dlange.cpp | 130 +- lib/linalg/dlanst.cpp | 106 +- lib/linalg/dlansy.cpp | 194 +- lib/linalg/dlapy2.cpp | 40 +- lib/linalg/dlapy3.cpp | 26 +- lib/linalg/dlarf.cpp | 102 +- lib/linalg/dlarfb.cpp | 648 +++---- lib/linalg/dlarfg.cpp | 90 +- lib/linalg/dlarft.cpp | 282 +-- lib/linalg/dlartg.cpp | 140 +- lib/linalg/dlas2.cpp | 82 +- lib/linalg/dlascl.cpp | 256 +-- lib/linalg/dlasd4.cpp | 1364 ++++++------- lib/linalg/dlasd5.cpp | 102 +- lib/linalg/dlasd6.cpp | 106 +- lib/linalg/dlasd7.cpp | 258 +-- lib/linalg/dlasd8.cpp | 168 +- lib/linalg/dlasda.cpp | 364 ++-- lib/linalg/dlasdq.cpp | 252 +-- lib/linalg/dlasdt.cpp | 44 +- lib/linalg/dlaset.cpp | 64 +- lib/linalg/dlasq1.cpp | 110 +- lib/linalg/dlasq2.cpp | 586 +++--- lib/linalg/dlasq3.cpp | 222 +-- lib/linalg/dlasq4.cpp | 430 ++--- lib/linalg/dlasq5.cpp | 444 ++--- lib/linalg/dlasq6.cpp | 152 +- lib/linalg/dlasr.cpp | 450 ++--- lib/linalg/dlasrt.cpp | 272 +-- lib/linalg/dlassq.cpp | 50 +- lib/linalg/dlasv2.cpp | 178 +- lib/linalg/dlaswp.cpp | 108 +- lib/linalg/dlatrd.cpp | 270 +-- lib/linalg/dlatrs.cpp | 760 ++++---- lib/linalg/dnrm2.cpp | 56 +- lib/linalg/dorg2l.cpp | 80 +- lib/linalg/dorg2r.cpp | 88 +- lib/linalg/dorgbr.cpp | 214 +-- lib/linalg/dorgl2.cpp | 98 +- lib/linalg/dorglq.cpp | 176 +- lib/linalg/dorgql.cpp | 188 +- lib/linalg/dorgqr.cpp | 176 +- lib/linalg/dorgtr.cpp | 164 +- lib/linalg/dorm2l.cpp | 94 +- lib/linalg/dorm2r.cpp | 102 +- lib/linalg/dormbr.cpp | 258 +-- lib/linalg/dorml2.cpp | 102 +- lib/linalg/dormlq.cpp | 208 +- lib/linalg/dormql.cpp | 198 +- lib/linalg/dormqr.cpp | 200 +- lib/linalg/dormtr.cpp | 196 +- lib/linalg/dposv.cpp | 50 +- lib/linalg/dpotf2.cpp | 134 +- lib/linalg/dpotrf.cpp | 180 +- lib/linalg/dpotrf2.cpp | 122 +- lib/linalg/dpotrs.cpp | 70 +- lib/linalg/drot.cpp | 66 +- lib/linalg/drscl.cpp | 44 +- lib/linalg/dscal.cpp | 72 +- lib/linalg/dstedc.cpp | 374 ++-- lib/linalg/dsteqr.cpp | 566 +++--- lib/linalg/dsterf.cpp | 402 ++-- lib/linalg/dswap.cpp | 104 +- lib/linalg/dsyev.cpp | 142 +- lib/linalg/dsyevd.cpp | 176 +- lib/linalg/dsygs2.cpp | 272 +-- lib/linalg/dsygst.cpp | 352 ++-- lib/linalg/dsygv.cpp | 148 +- lib/linalg/dsygvd.cpp | 142 +- lib/linalg/dsymm.cpp | 258 +-- lib/linalg/dsymv.cpp | 242 +-- lib/linalg/dsyr2.cpp | 196 +- lib/linalg/dsyr2k.cpp | 334 ++-- lib/linalg/dsyrk.cpp | 306 +-- lib/linalg/dsytd2.cpp | 156 +- lib/linalg/dsytrd.cpp | 186 +- lib/linalg/dtrmm.cpp | 418 ++-- lib/linalg/dtrmv.cpp | 314 +-- lib/linalg/dtrsm.cpp | 474 ++--- lib/linalg/dtrsv.cpp | 314 +-- lib/linalg/dtrti2.cpp | 104 +- lib/linalg/dtrtri.cpp | 152 +- lib/linalg/dznrm2.cpp | 80 +- lib/linalg/idamax.cpp | 58 +- lib/linalg/ieeeck.cpp | 74 +- lib/linalg/iladlc.cpp | 36 +- lib/linalg/iladlr.cpp | 38 +- lib/linalg/ilaenv.cpp | 872 ++++----- lib/linalg/ilazlc.cpp | 50 +- lib/linalg/ilazlr.cpp | 56 +- lib/linalg/iparmq.cpp | 206 +- lib/linalg/lmp_f2c.h | 170 +- lib/linalg/zaxpy.cpp | 84 +- lib/linalg/zcopy.cpp | 66 +- lib/linalg/zdotc.cpp | 78 +- lib/linalg/zdrot.cpp | 114 +- lib/linalg/zdscal.cpp | 62 +- lib/linalg/zgemm.cpp | 790 ++++---- lib/linalg/zgemv.cpp | 382 ++-- lib/linalg/zgerc.cpp | 140 +- lib/linalg/zheev.cpp | 148 +- lib/linalg/zheevd.cpp | 212 +-- lib/linalg/zhemv.cpp | 470 ++--- lib/linalg/zher2.cpp | 524 ++--- lib/linalg/zher2k.cpp | 840 ++++---- lib/linalg/zhetd2.cpp | 252 +-- lib/linalg/zhetrd.cpp | 206 +- lib/linalg/zhpr.cpp | 346 ++-- lib/linalg/zlacgv.cpp | 50 +- lib/linalg/zlacpy.cpp | 76 +- lib/linalg/zlacrm.cpp | 86 +- lib/linalg/zladiv.cpp | 24 +- lib/linalg/zlaed0.cpp | 224 +-- lib/linalg/zlaed7.cpp | 132 +- lib/linalg/zlaed8.cpp | 232 +-- lib/linalg/zlanhe.cpp | 244 +-- lib/linalg/zlarf.cpp | 110 +- lib/linalg/zlarfb.cpp | 764 ++++---- lib/linalg/zlarfg.cpp | 112 +- lib/linalg/zlarft.cpp | 372 ++-- lib/linalg/zlascl.cpp | 298 +-- lib/linalg/zlaset.cpp | 102 +- lib/linalg/zlasr.cpp | 762 ++++---- lib/linalg/zlassq.cpp | 74 +- lib/linalg/zlatrd.cpp | 396 ++-- lib/linalg/zpptrf.cpp | 140 +- lib/linalg/zpptri.cpp | 114 +- lib/linalg/zscal.cpp | 58 +- lib/linalg/zstedc.cpp | 364 ++-- lib/linalg/zsteqr.cpp | 576 +++--- lib/linalg/zswap.cpp | 82 +- lib/linalg/ztpmv.cpp | 760 ++++---- lib/linalg/ztpsv.cpp | 692 +++---- lib/linalg/ztptri.cpp | 174 +- lib/linalg/ztrmm.cpp | 876 ++++----- lib/linalg/ztrmv.cpp | 714 +++---- lib/linalg/zung2l.cpp | 102 +- lib/linalg/zung2r.cpp | 110 +- lib/linalg/zungl2.cpp | 130 +- lib/linalg/zungql.cpp | 198 +- lib/linalg/zungqr.cpp | 186 +- lib/linalg/zungtr.cpp | 188 +- lib/linalg/zunm2l.cpp | 116 +- lib/linalg/zunm2r.cpp | 124 +- lib/linalg/zunmql.cpp | 202 +- lib/linalg/zunmqr.cpp | 204 +- lib/linalg/zunmtr.cpp | 198 +- 194 files changed, 24511 insertions(+), 24511 deletions(-) diff --git a/lib/linalg/dasum.cpp b/lib/linalg/dasum.cpp index 0119bed6fd..93e40126c0 100644 --- a/lib/linalg/dasum.cpp +++ b/lib/linalg/dasum.cpp @@ -1,13 +1,13 @@ /* fortran/dasum.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -118,7 +118,7 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx) ret_val = 0.; dtemp = 0.; if (*n <= 0 || *incx <= 0) { - return ret_val; + return ret_val; } if (*incx == 1) { /* code for increment equal to 1 */ @@ -126,35 +126,35 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx) /* clean-up loop */ - m = *n % 6; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += (d__1 = dx[i__], abs(d__1)); - } - if (*n < 6) { - ret_val = dtemp; - return ret_val; - } - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 6) { - dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], - abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = - dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) - + (d__6 = dx[i__ + 5], abs(d__6)); - } + m = *n % 6; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += (d__1 = dx[i__], abs(d__1)); + } + if (*n < 6) { + ret_val = dtemp; + return ret_val; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 6) { + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], + abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = + dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + + (d__6 = dx[i__ + 5], abs(d__6)); + } } else { /* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dtemp += (d__1 = dx[i__], abs(d__1)); - } + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dtemp += (d__1 = dx[i__], abs(d__1)); + } } ret_val = dtemp; return ret_val; @@ -164,5 +164,5 @@ doublereal dasum_(integer *n, doublereal *dx, integer *incx) } /* dasum_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/daxpy.cpp b/lib/linalg/daxpy.cpp index d89cd6e9c4..54105d1426 100644 --- a/lib/linalg/daxpy.cpp +++ b/lib/linalg/daxpy.cpp @@ -1,13 +1,13 @@ /* fortran/daxpy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -102,8 +102,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, - integer *incx, doublereal *dy, integer *incy) +/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, + integer *incx, doublereal *dy, integer *incy) { /* System generated locals */ integer i__1; @@ -133,10 +133,10 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*da == 0.) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { @@ -145,43 +145,43 @@ extern "C" { /* clean-up loop */ - m = *n % 4; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] += *da * dx[i__]; - } - } - if (*n < 4) { - return 0; - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 4) { - dy[i__] += *da * dx[i__]; - dy[i__ + 1] += *da * dx[i__ + 1]; - dy[i__ + 2] += *da * dx[i__ + 2]; - dy[i__ + 3] += *da * dx[i__ + 3]; - } + m = *n % 4; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; + } + } + if (*n < 4) { + return 0; + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + dy[i__] += *da * dx[i__]; + dy[i__ + 1] += *da * dx[i__ + 1]; + dy[i__ + 2] += *da * dx[i__ + 2]; + dy[i__ + 3] += *da * dx[i__ + 3]; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] += *da * dx[ix]; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] += *da * dx[ix]; + ix += *incx; + iy += *incy; + } } return 0; @@ -190,5 +190,5 @@ extern "C" { } /* daxpy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dbdsqr.cpp b/lib/linalg/dbdsqr.cpp index 78c996dc2b..5f5c1b1d6f 100644 --- a/lib/linalg/dbdsqr.cpp +++ b/lib/linalg/dbdsqr.cpp @@ -1,13 +1,13 @@ /* fortran/dbdsqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -264,18 +264,18 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer * - nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, - integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer * - ldc, doublereal *work, integer *info, ftnlen uplo_len) + nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, + integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer * + ldc, doublereal *work, integer *info, ftnlen uplo_len) { /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; doublereal d__1, d__2, d__3, d__4; /* Builtin functions */ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign( - doublereal *, doublereal *); + doublereal *, doublereal *); /* Local variables */ integer iterdivn; @@ -294,30 +294,30 @@ f"> */ doublereal cosl; integer isub, iter; doublereal unfl, sinl, cosr, smin, smax, sinr; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *), dlas2_( - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *), dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *), dlas2_( + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal oldcs; - extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen, ftnlen); integer oldll; doublereal shift, sigmn, oldsn; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); doublereal sminl, sigmx; logical lower; extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *, - doublereal *, integer *), dlasv2_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + doublereal *, integer *), dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *), xerbla_(char *, - integer *, ftnlen); + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), xerbla_(char *, + integer *, ftnlen); doublereal sminoa, thresh; logical rotate; doublereal tolmul; @@ -366,32 +366,32 @@ f"> */ *info = 0; lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lower) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ncvt < 0) { - *info = -3; + *info = -3; } else if (*nru < 0) { - *info = -4; + *info = -4; } else if (*ncc < 0) { - *info = -5; + *info = -5; } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) { - *info = -9; + *info = -9; } else if (*ldu < max(1,*nru)) { - *info = -11; + *info = -11; } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) { - *info = -13; + *info = -13; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DBDSQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DBDSQR", &i__1, (ftnlen)6); + return 0; } if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - goto L160; + goto L160; } /* ROTATE is true if any singular vectors desired, false otherwise */ @@ -401,14 +401,14 @@ f"> */ /* If no singular vectors desired, use qd algorithm */ if (! rotate) { - dlasq1_(n, &d__[1], &e[1], &work[1], info); + dlasq1_(n, &d__[1], &e[1], &work[1], info); /* If INFO equals 2, dqds didn't finish, try to finish */ - if (*info != 2) { - return 0; - } - *info = 0; + if (*info != 2) { + return 0; + } + *info = 0; } nm1 = *n - 1; @@ -425,27 +425,27 @@ f"> */ /* by applying Givens rotations on the left */ if (lower) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - work[i__] = cs; - work[nm1 + i__] = sn; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + work[i__] = cs; + work[nm1 + i__] = sn; /* L10: */ - } + } /* Update singular vectors if desired */ - if (*nru > 0) { - dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[*n], &u[u_offset], - ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - if (*ncc > 0) { - dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[*n], &c__[c_offset], - ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (*nru > 0) { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[*n], &u[u_offset], + ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[*n], &c__[c_offset], + ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } } /* Compute singular values to relative accuracy TOL */ @@ -465,15 +465,15 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ - d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); - smax = max(d__2,d__3); + d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); + smax = max(d__2,d__3); /* L20: */ } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ - d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); - smax = max(d__2,d__3); + d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); + smax = max(d__2,d__3); /* L30: */ } sminl = 0.; @@ -481,33 +481,33 @@ f"> */ /* Relative accuracy desired */ - sminoa = abs(d__[1]); - if (sminoa == 0.) { - goto L50; - } - mu = sminoa; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] - , abs(d__1)))); - sminoa = min(sminoa,mu); - if (sminoa == 0.) { - goto L50; - } + sminoa = abs(d__[1]); + if (sminoa == 0.) { + goto L50; + } + mu = sminoa; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] + , abs(d__1)))); + sminoa = min(sminoa,mu); + if (sminoa == 0.) { + goto L50; + } /* L40: */ - } + } L50: - sminoa /= sqrt((doublereal) (*n)); + sminoa /= sqrt((doublereal) (*n)); /* Computing MAX */ - d__1 = tol * sminoa, d__2 = *n * (*n * unfl) * 6; - thresh = max(d__1,d__2); + d__1 = tol * sminoa, d__2 = *n * (*n * unfl) * 6; + thresh = max(d__1,d__2); } else { /* Absolute accuracy desired */ /* Computing MAX */ - d__1 = abs(tol) * smax, d__2 = *n * (*n * unfl) * 6; - thresh = max(d__1,d__2); + d__1 = abs(tol) * smax, d__2 = *n * (*n * unfl) * 6; + thresh = max(d__1,d__2); } /* Prepare for main iteration loop for the singular values */ @@ -531,39 +531,39 @@ L60: /* Check for convergence or exceeding iteration count */ if (m <= 1) { - goto L160; + goto L160; } if (iter >= *n) { - iter -= *n; - ++iterdivn; - if (iterdivn >= maxitdivn) { - goto L200; - } + iter -= *n; + ++iterdivn; + if (iterdivn >= maxitdivn) { + goto L200; + } } /* Find diagonal block of matrix to work on */ if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { - d__[m] = 0.; + d__[m] = 0.; } smax = (d__1 = d__[m], abs(d__1)); smin = smax; i__1 = m - 1; for (lll = 1; lll <= i__1; ++lll) { - ll = m - lll; - abss = (d__1 = d__[ll], abs(d__1)); - abse = (d__1 = e[ll], abs(d__1)); - if (tol < 0. && abss <= thresh) { - d__[ll] = 0.; - } - if (abse <= thresh) { - goto L80; - } - smin = min(smin,abss); + ll = m - lll; + abss = (d__1 = d__[ll], abs(d__1)); + abse = (d__1 = e[ll], abs(d__1)); + if (tol < 0. && abss <= thresh) { + d__[ll] = 0.; + } + if (abse <= thresh) { + goto L80; + } + smin = min(smin,abss); /* Computing MAX */ - d__1 = max(smax,abss); - smax = max(d__1,abse); + d__1 = max(smax,abss); + smax = max(d__1,abse); /* L70: */ } ll = 0; @@ -577,8 +577,8 @@ L80: /* Convergence of bottom singular value, return to top of loop */ - --m; - goto L60; + --m; + goto L60; } L90: ++ll; @@ -589,45 +589,45 @@ L90: /* 2 by 2 block, handle separately */ - dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, - &sinl, &cosl); - d__[m - 1] = sigmx; - e[m - 1] = 0.; - d__[m] = sigmn; + dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, + &sinl, &cosl); + d__[m - 1] = sigmx; + e[m - 1] = 0.; + d__[m] = sigmn; /* Compute singular vectors, if desired */ - if (*ncvt > 0) { - drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & - cosr, &sinr); - } - if (*nru > 0) { - drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & - c__1, &cosl, &sinl); - } - if (*ncc > 0) { - drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & - cosl, &sinl); - } - m += -2; - goto L60; + if (*ncvt > 0) { + drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & + cosr, &sinr); + } + if (*nru > 0) { + drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & + c__1, &cosl, &sinl); + } + if (*ncc > 0) { + drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & + cosl, &sinl); + } + m += -2; + goto L60; } /* If working on new submatrix, choose shift direction */ /* (from larger end diagonal element towards smaller) */ if (ll > oldm || m < oldll) { - if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { + if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { /* Chase bulge from top (big end) to bottom (small end) */ - idir = 1; - } else { + idir = 1; + } else { /* Chase bulge from bottom (big end) to top (small end) */ - idir = 2; - } + idir = 2; + } } /* Apply convergence tests */ @@ -637,63 +637,63 @@ L90: /* Run convergence test in forward direction */ /* First apply standard test to bottom of matrix */ - if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( - d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) - { - e[m - 1] = 0.; - goto L60; - } + if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( + d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) + { + e[m - 1] = 0.; + goto L60; + } - if (tol >= 0.) { + if (tol >= 0.) { /* If relative accuracy desired, */ /* apply convergence criterion forward */ - mu = (d__1 = d__[ll], abs(d__1)); - sminl = mu; - i__1 = m - 1; - for (lll = ll; lll <= i__1; ++lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ - lll], abs(d__1)))); - sminl = min(sminl,mu); + mu = (d__1 = d__[ll], abs(d__1)); + sminl = mu; + i__1 = m - 1; + for (lll = ll; lll <= i__1; ++lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ + lll], abs(d__1)))); + sminl = min(sminl,mu); /* L100: */ - } - } + } + } } else { /* Run convergence test in backward direction */ /* First apply standard test to top of matrix */ - if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) - ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { - e[ll] = 0.; - goto L60; - } + if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) + ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { + e[ll] = 0.; + goto L60; + } - if (tol >= 0.) { + if (tol >= 0.) { /* If relative accuracy desired, */ /* apply convergence criterion backward */ - mu = (d__1 = d__[m], abs(d__1)); - sminl = mu; - i__1 = ll; - for (lll = m - 1; lll >= i__1; --lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] - , abs(d__1)))); - sminl = min(sminl,mu); + mu = (d__1 = d__[m], abs(d__1)); + sminl = mu; + i__1 = ll; + for (lll = m - 1; lll >= i__1; --lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] + , abs(d__1)))); + sminl = min(sminl,mu); /* L110: */ - } - } + } + } } oldll = ll; oldm = m; @@ -707,28 +707,28 @@ L90: /* Use a zero shift to avoid loss of relative accuracy */ - shift = 0.; + shift = 0.; } else { /* Compute the shift from 2-by-2 block at end of matrix */ - if (idir == 1) { - sll = (d__1 = d__[ll], abs(d__1)); - dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); - } else { - sll = (d__1 = d__[m], abs(d__1)); - dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); - } + if (idir == 1) { + sll = (d__1 = d__[ll], abs(d__1)); + dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); + } else { + sll = (d__1 = d__[m], abs(d__1)); + dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); + } /* Test if shift negligible, and if so set to zero */ - if (sll > 0.) { + if (sll > 0.) { /* Computing 2nd power */ - d__1 = shift / sll; - if (d__1 * d__1 < eps) { - shift = 0.; - } - } + d__1 = shift / sll; + if (d__1 * d__1 < eps) { + shift = 0.; + } + } } /* Increment iteration count */ @@ -738,234 +738,234 @@ L90: /* If SHIFT = 0, do simplified QR iteration */ if (shift == 0.) { - if (idir == 1) { + if (idir == 1) { /* Chase bulge from top to bottom */ /* Save cosines and sines for later singular vector updates */ - cs = 1.; - oldcs = 1.; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__], &cs, &sn, &r__); - if (i__ > ll) { - e[i__ - 1] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ + 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll + 1] = cs; - work[i__ - ll + 1 + nm1] = sn; - work[i__ - ll + 1 + nm12] = oldcs; - work[i__ - ll + 1 + nm13] = oldsn; + cs = 1.; + oldcs = 1.; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__], &cs, &sn, &r__); + if (i__ > ll) { + e[i__ - 1] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ + 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll + 1] = cs; + work[i__ - ll + 1 + nm1] = sn; + work[i__ - ll + 1 + nm12] = oldcs; + work[i__ - ll + 1 + nm13] = oldsn; /* L120: */ - } - h__ = d__[m] * cs; - d__[m] = h__ * oldcs; - e[m - 1] = h__ * oldsn; + } + h__ = d__[m] * cs; + d__[m] = h__ * oldcs; + e[m - 1] = h__ * oldsn; /* Update singular vectors */ - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, - (ftnlen)1); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - } + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + } /* Test convergence */ - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } - } else { + } else { /* Chase bulge from bottom to top */ /* Save cosines and sines for later singular vector updates */ - cs = 1.; - oldcs = 1.; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); - if (i__ < m) { - e[i__] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ - 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll] = cs; - work[i__ - ll + nm1] = -sn; - work[i__ - ll + nm12] = oldcs; - work[i__ - ll + nm13] = -oldsn; + cs = 1.; + oldcs = 1.; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); + if (i__ < m) { + e[i__] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ - 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll] = cs; + work[i__ - ll + nm1] = -sn; + work[i__ - ll + nm12] = oldcs; + work[i__ - ll + nm13] = -oldsn; /* L130: */ - } - h__ = d__[ll] * cs; - d__[ll] = h__ * oldcs; - e[ll] = h__ * oldsn; + } + h__ = d__[ll] * cs; + d__[ll] = h__ * oldcs; + e[ll] = h__ * oldsn; /* Update singular vectors */ - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt[ll + vt_dim1], ldvt, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ - ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } /* Test convergence */ - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } - } + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + } } else { /* Use nonzero shift */ - if (idir == 1) { + if (idir == 1) { /* Chase bulge from top to bottom */ /* Save cosines and sines for later singular vector updates */ - f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ - ll]) + shift / d__[ll]); - g = e[ll]; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ > ll) { - e[i__ - 1] = r__; - } - f = cosr * d__[i__] + sinr * e[i__]; - e[i__] = cosr * e[i__] - sinr * d__[i__]; - g = sinr * d__[i__ + 1]; - d__[i__ + 1] = cosr * d__[i__ + 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__] + sinl * d__[i__ + 1]; - d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; - if (i__ < m - 1) { - g = sinl * e[i__ + 1]; - e[i__ + 1] = cosl * e[i__ + 1]; - } - work[i__ - ll + 1] = cosr; - work[i__ - ll + 1 + nm1] = sinr; - work[i__ - ll + 1 + nm12] = cosl; - work[i__ - ll + 1 + nm13] = sinl; + f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ + ll]) + shift / d__[ll]); + g = e[ll]; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ > ll) { + e[i__ - 1] = r__; + } + f = cosr * d__[i__] + sinr * e[i__]; + e[i__] = cosr * e[i__] - sinr * d__[i__]; + g = sinr * d__[i__ + 1]; + d__[i__ + 1] = cosr * d__[i__ + 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__] + sinl * d__[i__ + 1]; + d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; + if (i__ < m - 1) { + g = sinl * e[i__ + 1]; + e[i__ + 1] = cosl * e[i__ + 1]; + } + work[i__ - ll + 1] = cosr; + work[i__ - ll + 1 + nm1] = sinr; + work[i__ - ll + 1 + nm12] = cosl; + work[i__ - ll + 1 + nm13] = sinl; /* L140: */ - } - e[m - 1] = f; + } + e[m - 1] = f; /* Update singular vectors */ - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, - (ftnlen)1); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - } + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + } /* Test convergence */ - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } - } else { + } else { /* Chase bulge from bottom to top */ /* Save cosines and sines for later singular vector updates */ - f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] - ) + shift / d__[m]); - g = e[m - 1]; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ < m) { - e[i__] = r__; - } - f = cosr * d__[i__] + sinr * e[i__ - 1]; - e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; - g = sinr * d__[i__ - 1]; - d__[i__ - 1] = cosr * d__[i__ - 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; - d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; - if (i__ > ll + 1) { - g = sinl * e[i__ - 2]; - e[i__ - 2] = cosl * e[i__ - 2]; - } - work[i__ - ll] = cosr; - work[i__ - ll + nm1] = -sinr; - work[i__ - ll + nm12] = cosl; - work[i__ - ll + nm13] = -sinl; + f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] + ) + shift / d__[m]); + g = e[m - 1]; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ < m) { + e[i__] = r__; + } + f = cosr * d__[i__] + sinr * e[i__ - 1]; + e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; + g = sinr * d__[i__ - 1]; + d__[i__ - 1] = cosr * d__[i__ - 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; + d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; + if (i__ > ll + 1) { + g = sinl * e[i__ - 2]; + e[i__ - 2] = cosl * e[i__ - 2]; + } + work[i__ - ll] = cosr; + work[i__ - ll + nm1] = -sinr; + work[i__ - ll + nm12] = cosl; + work[i__ - ll + nm13] = -sinl; /* L150: */ - } - e[ll] = f; + } + e[ll] = f; /* Test convergence */ - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } /* Update singular vectors if desired */ - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt[ll + vt_dim1], ldvt, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ - ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - } + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } } /* QR iteration finished, go back and check convergence */ @@ -977,15 +977,15 @@ L90: L160: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] < 0.) { - d__[i__] = -d__[i__]; + if (d__[i__] < 0.) { + d__[i__] = -d__[i__]; /* Change sign of singular vectors, if desired */ - if (*ncvt > 0) { - dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); - } - } + if (*ncvt > 0) { + dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); + } + } /* L170: */ } @@ -997,35 +997,35 @@ L160: /* Scan for smallest D(I) */ - isub = 1; - smin = d__[1]; - i__2 = *n + 1 - i__; - for (j = 2; j <= i__2; ++j) { - if (d__[j] <= smin) { - isub = j; - smin = d__[j]; - } + isub = 1; + smin = d__[1]; + i__2 = *n + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (d__[j] <= smin) { + isub = j; + smin = d__[j]; + } /* L180: */ - } - if (isub != *n + 1 - i__) { + } + if (isub != *n + 1 - i__) { /* Swap singular values and vectors */ - d__[isub] = d__[*n + 1 - i__]; - d__[*n + 1 - i__] = smin; - if (*ncvt > 0) { - dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + - vt_dim1], ldvt); - } - if (*nru > 0) { - dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * - u_dim1 + 1], &c__1); - } - if (*ncc > 0) { - dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + - c_dim1], ldc); - } - } + d__[isub] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + + vt_dim1], ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * + u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + + c_dim1], ldc); + } + } /* L190: */ } goto L220; @@ -1036,9 +1036,9 @@ L200: *info = 0; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } + if (e[i__] != 0.) { + ++(*info); + } /* L210: */ } L220: @@ -1049,5 +1049,5 @@ L220: } /* dbdsqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dcabs1.cpp b/lib/linalg/dcabs1.cpp index 2733be3c74..bdaf645a57 100644 --- a/lib/linalg/dcabs1.cpp +++ b/lib/linalg/dcabs1.cpp @@ -1,13 +1,13 @@ /* fortran/dcabs1.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -88,5 +88,5 @@ doublereal dcabs1_(doublecomplex *z__) } /* dcabs1_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dcopy.cpp b/lib/linalg/dcopy.cpp index 52fe214e90..dceb6ad727 100644 --- a/lib/linalg/dcopy.cpp +++ b/lib/linalg/dcopy.cpp @@ -1,13 +1,13 @@ /* fortran/dcopy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -95,8 +95,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) +/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy) { /* System generated locals */ integer i__1; @@ -126,7 +126,7 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { @@ -135,46 +135,46 @@ extern "C" { /* clean-up loop */ - m = *n % 7; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] = dx[i__]; - } - if (*n < 7) { - return 0; - } - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 7) { - dy[i__] = dx[i__]; - dy[i__ + 1] = dx[i__ + 1]; - dy[i__ + 2] = dx[i__ + 2]; - dy[i__ + 3] = dx[i__ + 3]; - dy[i__ + 4] = dx[i__ + 4]; - dy[i__ + 5] = dx[i__ + 5]; - dy[i__ + 6] = dx[i__ + 6]; - } + m = *n % 7; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; + } + if (*n < 7) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 7) { + dy[i__] = dx[i__]; + dy[i__ + 1] = dx[i__ + 1]; + dy[i__ + 2] = dx[i__ + 2]; + dy[i__ + 3] = dx[i__ + 3]; + dy[i__ + 4] = dx[i__ + 4]; + dy[i__ + 5] = dx[i__ + 5]; + dy[i__ + 6] = dx[i__ + 6]; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] = dx[ix]; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; + } } return 0; @@ -183,5 +183,5 @@ extern "C" { } /* dcopy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ddot.cpp b/lib/linalg/ddot.cpp index 3f57f45459..e2319f6803 100644 --- a/lib/linalg/ddot.cpp +++ b/lib/linalg/ddot.cpp @@ -1,13 +1,13 @@ /* fortran/ddot.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -95,8 +95,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, - integer *incy) +doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, + integer *incy) { /* System generated locals */ integer i__1; @@ -130,7 +130,7 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, ret_val = 0.; dtemp = 0.; if (*n <= 0) { - return ret_val; + return ret_val; } if (*incx == 1 && *incy == 1) { @@ -139,43 +139,43 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, /* clean-up loop */ - m = *n % 5; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[i__] * dy[i__]; - } - if (*n < 5) { - ret_val = dtemp; - return ret_val; - } - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + - dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + - dx[i__ + 4] * dy[i__ + 4]; - } + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[i__] * dy[i__]; + } + if (*n < 5) { + ret_val = dtemp; + return ret_val; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + + dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + + dx[i__ + 4] * dy[i__ + 4]; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[ix] * dy[iy]; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[ix] * dy[iy]; + ix += *incx; + iy += *incy; + } } ret_val = dtemp; return ret_val; @@ -185,5 +185,5 @@ doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, } /* ddot_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgebd2.cpp b/lib/linalg/dgebd2.cpp index 399cd3ca6e..8c95869e21 100644 --- a/lib/linalg/dgebd2.cpp +++ b/lib/linalg/dgebd2.cpp @@ -1,13 +1,13 @@ /* fortran/dgebd2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -210,19 +210,19 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * - taup, doublereal *work, integer *info) + lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * + taup, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -261,126 +261,126 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info < 0) { - i__1 = -(*info); - xerbla_((char *)"DGEBD2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGEBD2", &i__1, (ftnlen)6); + return 0; } if (*m >= *n) { /* Reduce to upper bidiagonal form */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ - i__2 = *m - i__ + 1; + i__2 = *m - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * - a_dim1], &c__1, &tauq[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * + a_dim1], &c__1, &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; /* Apply H(i) to A(i:m,i+1:n) from the left */ - if (i__ < *n) { - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & - tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1] - , (ftnlen)4); - } - a[i__ + i__ * a_dim1] = d__[i__]; + if (i__ < *n) { + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1] + , (ftnlen)4); + } + a[i__ + i__ * a_dim1] = d__[i__]; - if (i__ < *n) { + if (i__ < *n) { /* Generate elementary reflector G(i) to annihilate */ /* A(i,i+2:n) */ - i__2 = *n - i__; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( - i__3,*n) * a_dim1], lda, &taup[i__]); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - a[i__ + (i__ + 1) * a_dim1] = 1.; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( + i__3,*n) * a_dim1], lda, &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; /* Apply G(i) to A(i+1:m,i+1:n) from the right */ - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], - lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &work[1], (ftnlen)5); - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } else { - taup[i__] = 0.; - } + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], + lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &work[1], (ftnlen)5); + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } else { + taup[i__] = 0.; + } /* L10: */ - } + } } else { /* Reduce to lower bidiagonal form */ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */ - i__2 = *n - i__ + 1; + i__2 = *n - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * - a_dim1], lda, &taup[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * + a_dim1], lda, &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; /* Apply G(i) to A(i+1:m,i:n) from the right */ - if (i__ < *m) { - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & - taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], - (ftnlen)5); - } - a[i__ + i__ * a_dim1] = d__[i__]; + if (i__ < *m) { + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & + taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], + (ftnlen)5); + } + a[i__ + i__ * a_dim1] = d__[i__]; - if (i__ < *m) { + if (i__ < *m) { /* Generate elementary reflector H(i) to annihilate */ /* A(i+2:m,i) */ - i__2 = *m - i__; + i__2 = *m - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + - i__ * a_dim1], &c__1, &tauq[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + + i__ * a_dim1], &c__1, &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; /* Apply H(i) to A(i+1:m,i+1:n) from the left */ - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & - c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &work[1], (ftnlen)4); - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } else { - tauq[i__] = 0.; - } + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & + c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &work[1], (ftnlen)4); + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } else { + tauq[i__] = 0.; + } /* L20: */ - } + } } return 0; @@ -389,5 +389,5 @@ f"> */ } /* dgebd2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgebrd.cpp b/lib/linalg/dgebrd.cpp index 84827afcfd..0be33bde5c 100644 --- a/lib/linalg/dgebrd.cpp +++ b/lib/linalg/dgebrd.cpp @@ -1,13 +1,13 @@ /* fortran/dgebrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -230,26 +230,26 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * - taup, doublereal *work, integer *lwork, integer *info) + lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * + taup, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, nb, nx, ws; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer nbmin, iinfo, minmn; - extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *), dlabrd_(integer *, integer *, integer * - , doublereal *, integer *, doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *, integer *, doublereal *, integer *) - , xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *), dlabrd_(integer *, integer *, integer * + , doublereal *, integer *, doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *, integer *, doublereal *, integer *) + , xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwrkx, ldwrky, lwkopt; logical lquery; @@ -293,38 +293,38 @@ f"> */ *info = 0; /* Computing MAX */ i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); + ftnlen)6, (ftnlen)1); nb = max(i__1,i__2); lwkopt = (*m + *n) * nb; work[1] = (doublereal) lwkopt; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = max(1,*m); - if (*lwork < max(i__1,*n) && ! lquery) { - *info = -10; - } + i__1 = max(1,*m); + if (*lwork < max(i__1,*n) && ! lquery) { + *info = -10; + } } if (*info < 0) { - i__1 = -(*info); - xerbla_((char *)"DGEBRD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGEBRD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ minmn = min(*m,*n); if (minmn == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } ws = max(*m,*n); @@ -336,31 +336,31 @@ f"> */ /* Set the crossover point NX. */ /* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); + i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); /* Determine when to switch from blocked to unblocked code. */ - if (nx < minmn) { - ws = (*m + *n) * nb; - if (*lwork < ws) { + if (nx < minmn) { + ws = (*m + *n) * nb; + if (*lwork < ws) { /* Not enough work space for the optimal NB, consider using */ /* a smaller block size. */ - nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - if (*lwork >= (*m + *n) * nbmin) { - nb = *lwork / (*m + *n); - } else { - nb = 1; - nx = minmn; - } - } - } + nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + if (*lwork >= (*m + *n) * nbmin) { + nb = *lwork / (*m + *n); + } else { + nb = 1; + nx = minmn; + } + } + } } else { - nx = minmn; + nx = minmn; } i__1 = minmn - nx; @@ -371,45 +371,45 @@ f"> */ /* the matrices X and Y which are needed to update the unreduced */ /* part of the matrix */ - i__3 = *m - i__ + 1; - i__4 = *n - i__ + 1; - dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ - i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx - * nb + 1], &ldwrky); + i__3 = *m - i__ + 1; + i__4 = *n - i__ + 1; + dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ + i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx + * nb + 1], &ldwrky); /* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */ /* of the form A := A - V*Y**T - X*U**T */ - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ - + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], & - ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, ( - ftnlen)12, (ftnlen)9); - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &nb, &c_b21, & - work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & - c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, ( - ftnlen)12); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ + + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], & + ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, ( + ftnlen)12, (ftnlen)9); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &nb, &c_b21, & + work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & + c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, ( + ftnlen)12); /* Copy diagonal and off-diagonal elements of B back into A */ - if (*m >= *n) { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + j * a_dim1] = d__[j]; - a[j + (j + 1) * a_dim1] = e[j]; + if (*m >= *n) { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + (j + 1) * a_dim1] = e[j]; /* L10: */ - } - } else { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + j * a_dim1] = d__[j]; - a[j + 1 + j * a_dim1] = e[j]; + } + } else { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + 1 + j * a_dim1] = e[j]; /* L20: */ - } - } + } + } /* L30: */ } @@ -418,7 +418,7 @@ f"> */ i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & - tauq[i__], &taup[i__], &work[1], &iinfo); + tauq[i__], &taup[i__], &work[1], &iinfo); work[1] = (doublereal) ws; return 0; @@ -427,5 +427,5 @@ f"> */ } /* dgebrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgecon.cpp b/lib/linalg/dgecon.cpp index 07a305d74f..76a0186cc8 100644 --- a/lib/linalg/dgecon.cpp +++ b/lib/linalg/dgecon.cpp @@ -1,13 +1,13 @@ /* fortran/dgecon.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -144,8 +144,8 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer * - lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info, ftnlen norm_len) + lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * + iwork, integer *info, ftnlen norm_len) { /* System generated locals */ integer a_dim1, a_offset, i__1; @@ -159,16 +159,16 @@ f"> */ doublereal scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer isave[3]; - extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, - integer *), dlacn2_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); + extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, + integer *), dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); extern doublereal dlamch_(char *, ftnlen); extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal ainvnm; - extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical onenrm; char normin[1]; doublereal smlnum; @@ -211,30 +211,30 @@ f"> */ /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, ( - ftnlen)1); + ftnlen)1); if (! onenrm && ! lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else if (*anorm < 0.) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGECON", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGECON", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ *rcond = 0.; if (*n == 0) { - *rcond = 1.; - return 0; + *rcond = 1.; + return 0; } else if (*anorm == 0.) { - return 0; + return 0; } smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12); @@ -244,61 +244,61 @@ f"> */ ainvnm = 0.; *(unsigned char *)normin = 'N'; if (onenrm) { - kase1 = 1; + kase1 = 1; } else { - kase1 = 2; + kase1 = 2; } kase = 0; L10: dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); if (kase != 0) { - if (kase == kase1) { + if (kase == kase1) { /* Multiply by inv(L). */ - dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, - (ftnlen)12, (ftnlen)4, (ftnlen)1); + dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset], + lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, + (ftnlen)12, (ftnlen)4, (ftnlen)1); /* Multiply by inv(U). */ - dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[ - a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, ( - ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); - } else { + dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, ( + ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); + } else { /* Multiply by inv(U**T). */ - dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset], - lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, ( - ftnlen)9, (ftnlen)8, (ftnlen)1); + dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset], + lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, ( + ftnlen)9, (ftnlen)8, (ftnlen)1); /* Multiply by inv(L**T). */ - dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, - (ftnlen)9, (ftnlen)4, (ftnlen)1); - } + dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset], + lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, + (ftnlen)9, (ftnlen)4, (ftnlen)1); + } /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ - scale = sl * su; - *(unsigned char *)normin = 'Y'; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; + scale = sl * su; + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; + *rcond = 1. / ainvnm / *anorm; } L20: @@ -309,5 +309,5 @@ L20: } /* dgecon_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgelq2.cpp b/lib/linalg/dgelq2.cpp index 6000253184..fec5ae2c50 100644 --- a/lib/linalg/dgelq2.cpp +++ b/lib/linalg/dgelq2.cpp @@ -1,13 +1,13 @@ /* fortran/dgelq2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -147,7 +147,7 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info) + lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -155,11 +155,11 @@ f"> */ /* Local variables */ integer i__, k; doublereal aii; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -195,16 +195,16 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGELQ2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGELQ2", &i__1, (ftnlen)6); + return 0; } k = min(*m,*n); @@ -214,24 +214,24 @@ f"> */ /* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ - i__2 = *n - i__ + 1; + i__2 = *n - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1] - , lda, &tau[i__]); - if (i__ < *m) { + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1] + , lda, &tau[i__]); + if (i__ < *m) { /* Apply H(i) to A(i+1:m,i:n) from the right */ - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ - i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen) - 5); - a[i__ + i__ * a_dim1] = aii; - } + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ + i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen) + 5); + a[i__ + i__ * a_dim1] = aii; + } /* L10: */ } return 0; @@ -241,5 +241,5 @@ f"> */ } /* dgelq2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgelqf.cpp b/lib/linalg/dgelqf.cpp index ede5b8198b..f6e60e5bcf 100644 --- a/lib/linalg/dgelqf.cpp +++ b/lib/linalg/dgelqf.cpp @@ -1,13 +1,13 @@ /* fortran/dgelqf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -167,23 +167,23 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) + lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, k, ib, nb, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, - char *, char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, + char *, char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -221,33 +221,33 @@ f"> */ /* Function Body */ *info = 0; nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); + 1); lwkopt = *m * nb; work[1] = (doublereal) lwkopt; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } else if (*lwork < max(1,*m) && ! lquery) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGELQF", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGELQF", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ k = min(*m,*n); if (k == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; @@ -258,79 +258,79 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < k && nx < k) { /* Use blocked code initially */ - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__3 = k - i__ + 1; - ib = min(i__3,nb); + i__3 = k - i__ + 1; + ib = min(i__3,nb); /* Compute the LQ factorization of the current block */ /* A(i:i+ib-1,i:n) */ - i__3 = *n - i__ + 1; - dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ - 1], &iinfo); - if (i__ + ib <= *m) { + i__3 = *n - i__ + 1; + dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *m) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__3 = *n - i__ + 1; - dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, - (ftnlen)7); + i__3 = *n - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, + (ftnlen)7); /* Apply H to A(i+ib:m,i:n) from the right */ - i__3 = *m - i__ - ib + 1; - i__4 = *n - i__ + 1; - dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3, - &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, ( - ftnlen)7); - } + i__3 = *m - i__ - ib + 1; + i__4 = *n - i__ + 1; + dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3, + &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + + 1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, ( + ftnlen)7); + } /* L10: */ - } + } } else { - i__ = 1; + i__ = 1; } /* Use unblocked code to factor the last or only block. */ if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] - , &iinfo); + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] + , &iinfo); } work[1] = (doublereal) iws; @@ -341,5 +341,5 @@ f"> */ } /* dgelqf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgelsd.cpp b/lib/linalg/dgelsd.cpp index 7a74d30ef2..ffe7446f85 100644 --- a/lib/linalg/dgelsd.cpp +++ b/lib/linalg/dgelsd.cpp @@ -1,13 +1,13 @@ /* fortran/dgelsd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -234,10 +234,10 @@ f"> */ /* > Osni Marques, LBNL/NERSC, USA \n */ /* ===================================================================== */ -/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, - integer *iwork, integer *info) +/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, + integer *iwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; @@ -252,39 +252,39 @@ f"> */ doublereal sfmin; integer minmn, maxmn, itaup, itauq, mnthr, nwork; extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_( - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *); - extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, ftnlen); - extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *), - dlalsd_(char *, integer *, integer *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, integer *, ftnlen), dlascl_(char *, - integer *, integer *, doublereal *, doublereal *, integer *, - integer *, doublereal *, integer *, integer *, ftnlen), dgeqrf_( - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, integer *), dlacpy_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen), dlaset_(char *, integer *, integer *, doublereal *, - doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *, - integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, ftnlen); + extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlalsd_(char *, integer *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, ftnlen), dlascl_(char *, + integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen), dgeqrf_( + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), dlaset_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); doublereal bignum; - extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *, - ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen, ftnlen); integer wlalsd; - extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer ldwork; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer liwork, minwrk, maxwrk; doublereal smlnum; logical lquery; @@ -332,22 +332,22 @@ f"> */ minmn = min(*m,*n); maxmn = max(*m,*n); mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, ( - ftnlen)1); + ftnlen)1); lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*nrhs < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,maxmn)) { - *info = -7; + *info = -7; } smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( - ftnlen)6, (ftnlen)1); + ftnlen)6, (ftnlen)1); /* Compute workspace. */ /* (Note: Comments in the code beginning (char *)"Workspace:" describe the */ @@ -360,151 +360,151 @@ f"> */ liwork = 1; minmn = max(1,minmn); /* Computing MAX */ - i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) / - log(2.)) + 1; + i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) / + log(2.)) + 1; nlvl = max(i__1,0); if (*info == 0) { - maxwrk = 0; - liwork = minmn * 3 * nlvl + minmn * 11; - mm = *m; - if (*m >= *n && *m >= mnthr) { + maxwrk = 0; + liwork = minmn * 3 * nlvl + minmn * 11; + mm = *m; + if (*m >= *n && *m >= mnthr) { /* Path 1a - overdetermined, with many more rows than columns. */ - mm = *n; + mm = *n; /* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, - n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, + n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT", - m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); - maxwrk = max(i__1,i__2); - } - if (*m >= *n) { + i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT", + m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); + maxwrk = max(i__1,i__2); + } + if (*m >= *n) { /* Path 1 - overdetermined or exactly determined. */ /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, (char *)"DGEBRD" - , (char *)" ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, (char *)"DGEBRD" + , (char *)" ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", - (char *)"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", + (char *)"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, (char *)"DORMBR", - (char *)"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, (char *)"DORMBR", + (char *)"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1,i__2); /* Computing 2nd power */ - i__1 = smlsiz + 1; - wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * * - nrhs + i__1 * i__1; + i__1 = smlsiz + 1; + wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * * + nrhs + i__1 * i__1; /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + wlalsd; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + wlalsd; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2), - i__2 = *n * 3 + wlalsd; - minwrk = max(i__1,i__2); - } - if (*n > *m) { + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2), + i__2 = *n * 3 + wlalsd; + minwrk = max(i__1,i__2); + } + if (*n > *m) { /* Computing 2nd power */ - i__1 = smlsiz + 1; - wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * * - nrhs + i__1 * i__1; - if (*n >= mnthr) { + i__1 = smlsiz + 1; + wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * * + nrhs + i__1 * i__1; + if (*n >= mnthr) { /* Path 2a - underdetermined, with many more columns */ /* than rows. */ - maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, - &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, + &c_n1, (ftnlen)6, (ftnlen)1); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * - ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * + ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& - c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, (ftnlen)6, ( - ftnlen)3); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& + c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, (ftnlen)6, ( + ftnlen)3); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * - ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, ( - ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); - if (*nrhs > 1) { + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * + ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, ( + ftnlen)6, (ftnlen)3); + maxwrk = max(i__1,i__2); + if (*nrhs > 1) { /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; - maxwrk = max(i__1,i__2); - } else { + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = max(i__1,i__2); + } else { /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 1); - maxwrk = max(i__1,i__2); - } + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = max(i__1,i__2); + } /* Computing MAX */ - i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ", - (char *)"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ", + (char *)"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; + maxwrk = max(i__1,i__2); /* XXX: Ensure the Path 2a case below is triggered. The workspace */ /* calculation should use queries for all routines eventually. */ /* Computing MAX */ /* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = - max(i__3,*nrhs), i__4 = *n - *m * 3; - i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4); - maxwrk = max(i__1,i__2); - } else { + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = + max(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4); + maxwrk = max(i__1,i__2); + } else { /* Path 2 - remaining underdetermined cases. */ - maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, - n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, + n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR" - , (char *)"QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR" + , (char *)"QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR", - (char *)"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR", + (char *)"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + wlalsd; - maxwrk = max(i__1,i__2); - } + i__1 = maxwrk, i__2 = *m * 3 + wlalsd; + maxwrk = max(i__1,i__2); + } /* Computing MAX */ - i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2), - i__2 = *m * 3 + wlalsd; - minwrk = max(i__1,i__2); - } - minwrk = min(minwrk,maxwrk); - work[1] = (doublereal) maxwrk; - iwork[1] = liwork; - if (*lwork < minwrk && ! lquery) { - *info = -12; - } + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2), + i__2 = *m * 3 + wlalsd; + minwrk = max(i__1,i__2); + } + minwrk = min(minwrk,maxwrk); + work[1] = (doublereal) maxwrk; + iwork[1] = liwork; + if (*lwork < minwrk && ! lquery) { + *info = -12; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGELSD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGELSD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - goto L10; + goto L10; } /* Quick return if possible. */ if (*m == 0 || *n == 0) { - *rank = 0; - return 0; + *rank = 0; + return 0; } /* Get machine parameters. */ @@ -523,26 +523,26 @@ f"> */ /* Scale matrix norm up to SMLNUM. */ - dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info, (ftnlen)1); - iascl = 1; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info, (ftnlen)1); + iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM. */ - dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info, (ftnlen)1); - iascl = 2; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info, (ftnlen)1); + iascl = 2; } else if (anrm == 0.) { /* Matrix all zero. Return zero solution. */ - i__1 = max(*m,*n); - dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen) - 1); - dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1); - *rank = 0; - goto L10; + i__1 = max(*m,*n); + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen) + 1); + dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1); + *rank = 0; + goto L10; } /* Scale B if max entry outside range [SMLNUM,BIGNUM]. */ @@ -553,24 +553,24 @@ f"> */ /* Scale matrix norm up to SMLNUM. */ - dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - ibscl = 1; + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM. */ - dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - ibscl = 2; + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + ibscl = 2; } /* If M < N make sure certain entries of B are zero. */ if (*m < *n) { - i__1 = *n - *m; - dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, ( - ftnlen)1); + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, ( + ftnlen)1); } /* Overdetermined case. */ @@ -579,227 +579,227 @@ f"> */ /* Path 1 - overdetermined or exactly determined. */ - mm = *m; - if (*m >= mnthr) { + mm = *m; + if (*m >= mnthr) { /* Path 1a - overdetermined, with many more rows than columns. */ - mm = *n; - itau = 1; - nwork = itau + *n; + mm = *n; + itau = 1; + nwork = itau + *n; /* Compute A=Q*R. */ /* (Workspace: need 2*N, prefer N+N*NB) */ - i__1 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, - info); + i__1 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); /* Multiply B by transpose(Q). */ /* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ - i__1 = *lwork - nwork + 1; - dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( - ftnlen)1); + i__1 = *lwork - nwork + 1; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( + ftnlen)1); /* Zero out below R. */ - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], - lda, (ftnlen)1); - } - } + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], + lda, (ftnlen)1); + } + } - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; /* Bidiagonalize R in A. */ /* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ - i__1 = *lwork - nwork + 1; - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors of R. */ /* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], - &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); /* Solve the bidiagonal least squares problem. */ - dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, - rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)1); - if (*info != 0) { - goto L10; - } + dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, + rcond, rank, &work[nwork], &iwork[1], info, (ftnlen)1); + if (*info != 0) { + goto L10; + } /* Multiply B by right bidiagonalizing vectors of R. */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & - b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & + b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max( - i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2); - if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) { + i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max( + i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2); + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) { /* Path 2a - underdetermined, with many more columns than rows */ /* and sufficient workspace for an efficient algorithm. */ - ldwork = *m; + ldwork = *m; /* Computing MAX */ /* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = - max(i__3,*nrhs), i__4 = *n - *m * 3; - i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda + - *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2) - + *m * *lda + wlalsd; - if (*lwork >= max(i__1,i__2)) { - ldwork = *lda; - } - itau = 1; - nwork = *m + 1; + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = + max(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda + + *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2) + + *m * *lda + wlalsd; + if (*lwork >= max(i__1,i__2)) { + ldwork = *lda; + } + itau = 1; + nwork = *m + 1; /* Compute A=L*Q. */ /* (Workspace: need 2*M, prefer M+M*NB) */ - i__1 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, - info); - il = nwork; + i__1 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); + il = nwork; /* Copy L to WORK(IL), zeroing out above its diagonal. */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen) - 1); - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], & - ldwork, (ftnlen)1); - ie = il + ldwork * *m; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen) + 1); + i__1 = *m - 1; + i__2 = *m - 1; + dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], & + ldwork, (ftnlen)1); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; /* Bidiagonalize L in WORK(IL). */ /* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], - &work[itaup], &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[nwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors of L. */ /* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[ - itauq], &b[b_offset], ldb, &work[nwork], &i__1, info, ( - ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[nwork], &i__1, info, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); /* Solve the bidiagonal least squares problem. */ - dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], - ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) - 1); - if (*info != 0) { - goto L10; - } + dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) + 1); + if (*info != 0) { + goto L10; + } /* Multiply B by right bidiagonalizing vectors of L. */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[ - itaup], &b[b_offset], ldb, &work[nwork], &i__1, info, ( - ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[ + itaup], &b[b_offset], ldb, &work[nwork], &i__1, info, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); /* Zero out below first M rows of B. */ - i__1 = *n - *m; - dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], - ldb, (ftnlen)1); - nwork = itau + *m; + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], + ldb, (ftnlen)1); + nwork = itau + *m; /* Multiply transpose(Q) by B. */ /* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ - i__1 = *lwork - nwork + 1; - dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( - ftnlen)1); + i__1 = *lwork - nwork + 1; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, ( + ftnlen)1); - } else { + } else { /* Path 2 - remaining underdetermined cases. */ - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; /* Bidiagonalize A. */ /* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - i__1 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors. */ /* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq] - , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, - (ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq] + , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, + (ftnlen)1, (ftnlen)1); /* Solve the bidiagonal least squares problem. */ - dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], - ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) - 1); - if (*info != 0) { - goto L10; - } + dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &iwork[1], info, (ftnlen) + 1); + if (*info != 0) { + goto L10; + } /* Multiply B by right bidiagonalizing vectors of A. */ - i__1 = *lwork - nwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, m, &a[a_offset], lda, &work[itaup] - , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, - (ftnlen)1, (ftnlen)1); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, m, &a[a_offset], lda, &work[itaup] + , &b[b_offset], ldb, &work[nwork], &i__1, info, (ftnlen)1, + (ftnlen)1, (ftnlen)1); - } + } } /* Undo scaling. */ if (iascl == 1) { - dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info, (ftnlen)1); } else if (iascl == 2) { - dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info, (ftnlen)1); } if (ibscl == 1) { - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); } else if (ibscl == 2) { - dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); } L10: @@ -812,5 +812,5 @@ L10: } /* dgelsd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgelss.cpp b/lib/linalg/dgelss.cpp index 6377208923..86036f9179 100644 --- a/lib/linalg/dgelss.cpp +++ b/lib/linalg/dgelss.cpp @@ -1,13 +1,13 @@ /* fortran/dgelss.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -196,10 +196,10 @@ f"> */ /* > \ingroup doubleGEsolve */ /* ===================================================================== */ -/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, - integer *info) +/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, + integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; @@ -208,58 +208,58 @@ f"> */ /* Local variables */ integer i__, bl, ie, il, mm; doublereal dum[1], eps, thr, anrm, bnrm; - integer itau, lwork_dgebrd__, lwork_dgelqf__, lwork_dgeqrf__, - lwork_dorgbr__, lwork_dormbr__, lwork_dormlq__, lwork_dormqr__; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + integer itau, lwork_dgebrd__, lwork_dgelqf__, lwork_dgeqrf__, + lwork_dorgbr__, lwork_dormbr__, lwork_dormlq__, lwork_dormqr__; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer iascl, ibscl; - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen), drscl_(integer *, - doublereal *, doublereal *, integer *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen), drscl_(integer *, + doublereal *, doublereal *, integer *); integer chunk; doublereal sfmin; integer minmn; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer maxmn, itaup, itauq, mnthr, iwork; extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_( - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *); - extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, ftnlen); + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, ftnlen); integer bdspac; - extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *), - dlascl_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *, ftnlen), - dgeqrf_(integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *, ftnlen), dlaset_(char *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, ftnlen), - xerbla_(char *, integer *, ftnlen), dbdsqr_(char *, integer *, - integer *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen), dorgbr_(char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *, ftnlen); + extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlascl_(char *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *, ftnlen), + dgeqrf_(integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen), dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, ftnlen), + xerbla_(char *, integer *, ftnlen), dbdsqr_(char *, integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen), dorgbr_(char *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *, ftnlen); doublereal bignum; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *, - ftnlen, ftnlen, ftnlen), dormlq_(char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *, - ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen, ftnlen), dormlq_(char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); integer ldwork; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); integer minwrk, maxwrk; doublereal smlnum; logical lquery; @@ -308,15 +308,15 @@ f"> */ maxmn = max(*m,*n); lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*nrhs < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,maxmn)) { - *info = -7; + *info = -7; } /* Compute workspace */ @@ -327,193 +327,193 @@ f"> */ /* following subroutine, as returned by ILAENV.) */ if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (minmn > 0) { - mm = *m; - mnthr = ilaenv_(&c__6, (char *)"DGELSS", (char *)" ", m, n, nrhs, &c_n1, (ftnlen) - 6, (ftnlen)1); - if (*m >= *n && *m >= mnthr) { + minwrk = 1; + maxwrk = 1; + if (minmn > 0) { + mm = *m; + mnthr = ilaenv_(&c__6, (char *)"DGELSS", (char *)" ", m, n, nrhs, &c_n1, (ftnlen) + 6, (ftnlen)1); + if (*m >= *n && *m >= mnthr) { /* Path 1a - overdetermined, with many more rows than */ /* columns */ /* Compute space needed for DGEQRF */ - dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); - lwork_dgeqrf__ = (integer) dum[0]; + dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_dgeqrf__ = (integer) dum[0]; /* Compute space needed for DORMQR */ - dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, &b[ - b_offset], ldb, dum, &c_n1, info, (ftnlen)1, (ftnlen) - 1); - lwork_dormqr__ = (integer) dum[0]; - mm = *n; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, &b[ + b_offset], ldb, dum, &c_n1, info, (ftnlen)1, (ftnlen) + 1); + lwork_dormqr__ = (integer) dum[0]; + mm = *n; /* Computing MAX */ - i__1 = maxwrk, i__2 = *n + lwork_dgeqrf__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n + lwork_dgeqrf__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n + lwork_dormqr__; - maxwrk = max(i__1,i__2); - } - if (*m >= *n) { + i__1 = maxwrk, i__2 = *n + lwork_dormqr__; + maxwrk = max(i__1,i__2); + } + if (*m >= *n) { /* Path 1 - overdetermined or exactly determined */ /* Compute workspace needed for DBDSQR */ /* Computing MAX */ - i__1 = 1, i__2 = *n * 5; - bdspac = max(i__1,i__2); + i__1 = 1, i__2 = *n * 5; + bdspac = max(i__1,i__2); /* Compute space needed for DGEBRD */ - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, - &c_n1, info); - lwork_dgebrd__ = (integer) dum[0]; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, + &c_n1, info); + lwork_dgebrd__ = (integer) dum[0]; /* Compute space needed for DORMBR */ - dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, dum, & - b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - lwork_dormbr__ = (integer) dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, dum, & + b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer) dum[0]; /* Compute space needed for DORGBR */ - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, - info, (ftnlen)1); - lwork_dorgbr__ = (integer) dum[0]; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, + info, (ftnlen)1); + lwork_dorgbr__ = (integer) dum[0]; /* Compute total workspace needed */ /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + lwork_dgebrd__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + lwork_dgebrd__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + lwork_dormbr__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * 3 + lwork_dormbr__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + lwork_dorgbr__; - maxwrk = max(i__1,i__2); - maxwrk = max(maxwrk,bdspac); + i__1 = maxwrk, i__2 = *n * 3 + lwork_dorgbr__; + maxwrk = max(i__1,i__2); + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1, - i__2); - minwrk = max(i__1,bdspac); - maxwrk = max(minwrk,maxwrk); - } - if (*n > *m) { + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1, + i__2); + minwrk = max(i__1,bdspac); + maxwrk = max(minwrk,maxwrk); + } + if (*n > *m) { /* Compute workspace needed for DBDSQR */ /* Computing MAX */ - i__1 = 1, i__2 = *m * 5; - bdspac = max(i__1,i__2); + i__1 = 1, i__2 = *m * 5; + bdspac = max(i__1,i__2); /* Computing MAX */ - i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1, - i__2); - minwrk = max(i__1,bdspac); - if (*n >= mnthr) { + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1, + i__2); + minwrk = max(i__1,bdspac); + if (*n >= mnthr) { /* Path 2a - underdetermined, with many more columns */ /* than rows */ /* Compute space needed for DGELQF */ - dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); - lwork_dgelqf__ = (integer) dum[0]; + dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_dgelqf__ = (integer) dum[0]; /* Compute space needed for DGEBRD */ - dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, - dum, &c_n1, info); - lwork_dgebrd__ = (integer) dum[0]; + dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, + dum, &c_n1, info); + lwork_dgebrd__ = (integer) dum[0]; /* Compute space needed for DORMBR */ - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, - &b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - lwork_dormbr__ = (integer) dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, + &b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer) dum[0]; /* Compute space needed for DORGBR */ - dorgbr_((char *)"P", m, m, m, &a[a_offset], lda, dum, dum, &c_n1, - info, (ftnlen)1); - lwork_dorgbr__ = (integer) dum[0]; + dorgbr_((char *)"P", m, m, m, &a[a_offset], lda, dum, dum, &c_n1, + info, (ftnlen)1); + lwork_dorgbr__ = (integer) dum[0]; /* Compute space needed for DORMLQ */ - dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, dum, &b[ - b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( - ftnlen)1); - lwork_dormlq__ = (integer) dum[0]; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, dum, &b[ + b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( + ftnlen)1); + lwork_dormlq__ = (integer) dum[0]; /* Compute total workspace needed */ - maxwrk = *m + lwork_dgelqf__; + maxwrk = *m + lwork_dgelqf__; /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + - lwork_dgebrd__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + lwork_dgebrd__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + - lwork_dormbr__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + lwork_dormbr__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + - lwork_dorgbr__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + lwork_dorgbr__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; - maxwrk = max(i__1,i__2); - if (*nrhs > 1) { + i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; + maxwrk = max(i__1,i__2); + if (*nrhs > 1) { /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; - maxwrk = max(i__1,i__2); - } else { + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = max(i__1,i__2); + } else { /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 1); - maxwrk = max(i__1,i__2); - } + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = max(i__1,i__2); + } /* Computing MAX */ - i__1 = maxwrk, i__2 = *m + lwork_dormlq__; - maxwrk = max(i__1,i__2); - } else { + i__1 = maxwrk, i__2 = *m + lwork_dormlq__; + maxwrk = max(i__1,i__2); + } else { /* Path 2 - underdetermined */ /* Compute space needed for DGEBRD */ - dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, - dum, &c_n1, info); - lwork_dgebrd__ = (integer) dum[0]; + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, + dum, &c_n1, info); + lwork_dgebrd__ = (integer) dum[0]; /* Compute space needed for DORMBR */ - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &a[a_offset], lda, dum, - &b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - lwork_dormbr__ = (integer) dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &a[a_offset], lda, dum, + &b[b_offset], ldb, dum, &c_n1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer) dum[0]; /* Compute space needed for DORGBR */ - dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, dum, dum, &c_n1, - info, (ftnlen)1); - lwork_dorgbr__ = (integer) dum[0]; - maxwrk = *m * 3 + lwork_dgebrd__; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, dum, dum, &c_n1, + info, (ftnlen)1); + lwork_dorgbr__ = (integer) dum[0]; + maxwrk = *m * 3 + lwork_dgebrd__; /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + lwork_dormbr__; - maxwrk = max(i__1,i__2); + i__1 = maxwrk, i__2 = *m * 3 + lwork_dormbr__; + maxwrk = max(i__1,i__2); /* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + lwork_dorgbr__; - maxwrk = max(i__1,i__2); - maxwrk = max(maxwrk,bdspac); + i__1 = maxwrk, i__2 = *m * 3 + lwork_dorgbr__; + maxwrk = max(i__1,i__2); + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = max(i__1,i__2); - } - } - maxwrk = max(minwrk,maxwrk); - } - work[1] = (doublereal) maxwrk; + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = max(i__1,i__2); + } + } + maxwrk = max(minwrk,maxwrk); + } + work[1] = (doublereal) maxwrk; - if (*lwork < minwrk && ! lquery) { - *info = -12; - } + if (*lwork < minwrk && ! lquery) { + *info = -12; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGELSS", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGELSS", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - *rank = 0; - return 0; + *rank = 0; + return 0; } /* Get machine parameters */ @@ -532,26 +532,26 @@ f"> */ /* Scale matrix norm up to SMLNUM */ - dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info, (ftnlen)1); - iascl = 1; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info, (ftnlen)1); + iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM */ - dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info, (ftnlen)1); - iascl = 2; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info, (ftnlen)1); + iascl = 2; } else if (anrm == 0.) { /* Matrix all zero. Return zero solution. */ - i__1 = max(*m,*n); - dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[b_offset], ldb, (ftnlen) - 1); - dlaset_((char *)"F", &minmn, &c__1, &c_b46, &c_b46, &s[1], &minmn, (ftnlen)1); - *rank = 0; - goto L70; + i__1 = max(*m,*n); + dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[b_offset], ldb, (ftnlen) + 1); + dlaset_((char *)"F", &minmn, &c__1, &c_b46, &c_b46, &s[1], &minmn, (ftnlen)1); + *rank = 0; + goto L70; } /* Scale B if max element outside range [SMLNUM,BIGNUM] */ @@ -562,16 +562,16 @@ f"> */ /* Scale matrix norm up to SMLNUM */ - dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - ibscl = 1; + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM */ - dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - ibscl = 2; + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + ibscl = 2; } /* Overdetermined case */ @@ -580,399 +580,399 @@ f"> */ /* Path 1 - overdetermined or exactly determined */ - mm = *m; - if (*m >= mnthr) { + mm = *m; + if (*m >= mnthr) { /* Path 1a - overdetermined, with many more rows than columns */ - mm = *n; - itau = 1; - iwork = itau + *n; + mm = *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need 2*N, prefer N+N*NB) */ - i__1 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, - info); + i__1 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, + info); /* Multiply B by transpose(Q) */ /* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ - i__1 = *lwork - iwork + 1; - dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( - ftnlen)1); + i__1 = *lwork - iwork + 1; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( + ftnlen)1); /* Zero out below R */ - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_((char *)"L", &i__1, &i__2, &c_b46, &c_b46, &a[a_dim1 + 2], - lda, (ftnlen)1); - } - } + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__1, &i__2, &c_b46, &c_b46, &a[a_dim1 + 2], + lda, (ftnlen)1); + } + } - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in A */ /* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ - i__1 = *lwork - iwork + 1; - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); + i__1 = *lwork - iwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors of R */ /* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ - i__1 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], - &b[b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + i__1 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); /* Generate right bidiagonalizing vectors of R in A */ /* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - i__1 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & - i__1, info, (ftnlen)1); - iwork = ie + *n; + i__1 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & + i__1, info, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration */ /* multiply B by transpose of left singular vectors */ /* compute right singular vectors in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, - dum, &c__1, &b[b_offset], ldb, &work[iwork], info, (ftnlen)1); - if (*info != 0) { - goto L70; - } + dbdsqr_((char *)"U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, + dum, &c__1, &b[b_offset], ldb, &work[iwork], info, (ftnlen)1); + if (*info != 0) { + goto L70; + } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { + d__1 = *rcond * s[1]; + thr = max(d__1,sfmin); + if (*rcond < 0.) { /* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1], - ldb, (ftnlen)1); - } + d__1 = eps * s[1]; + thr = max(d__1,sfmin); + } + *rank = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1], + ldb, (ftnlen)1); + } /* L10: */ - } + } /* Multiply B by right singular vectors */ /* (Workspace: need N, prefer N*NRHS) */ - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b79, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b46, &work[1], ldb, (ftnlen)1, (ftnlen) - 1); - dlacpy_((char *)"G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, (ftnlen)1) - ; - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b79, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b46, &work[1], ldb, (ftnlen)1, (ftnlen) + 1); + dlacpy_((char *)"G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, (ftnlen)1) + ; + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_((char *)"T", (char *)"N", n, &bl, n, &c_b79, &a[a_offset], lda, &b[i__ - * b_dim1 + 1], ldb, &c_b46, &work[1], n, (ftnlen)1, ( - ftnlen)1); - dlacpy_((char *)"G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb, ( - ftnlen)1); + i__3 = *nrhs - i__ + 1; + bl = min(i__3,chunk); + dgemm_((char *)"T", (char *)"N", n, &bl, n, &c_b79, &a[a_offset], lda, &b[i__ + * b_dim1 + 1], ldb, &c_b46, &work[1], n, (ftnlen)1, ( + ftnlen)1); + dlacpy_((char *)"G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb, ( + ftnlen)1); /* L20: */ - } - } else { - dgemv_((char *)"T", n, n, &c_b79, &a[a_offset], lda, &b[b_offset], &c__1, - &c_b46, &work[1], &c__1, (ftnlen)1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } + } + } else { + dgemv_((char *)"T", n, n, &c_b79, &a[a_offset], lda, &b[b_offset], &c__1, + &c_b46, &work[1], &c__1, (ftnlen)1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } } else /* if(complicated condition) */ { /* Computing MAX */ - i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max( - i__2,*nrhs), i__1 = *n - *m * 3; - if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) { + i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max( + i__2,*nrhs), i__1 = *n - *m * 3; + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) { /* Path 2a - underdetermined, with many more columns than rows */ /* and sufficient workspace for an efficient algorithm */ - ldwork = *m; + ldwork = *m; /* Computing MAX */ /* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = - max(i__3,*nrhs), i__4 = *n - *m * 3; - i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda + - *m + *m * *nrhs; - if (*lwork >= max(i__2,i__1)) { - ldwork = *lda; - } - itau = 1; - iwork = *m + 1; + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = + max(i__3,*nrhs), i__4 = *n - *m * 3; + i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda + + *m + *m * *nrhs; + if (*lwork >= max(i__2,i__1)) { + ldwork = *lda; + } + itau = 1; + iwork = *m + 1; /* Compute A=L*Q */ /* (Workspace: need 2*M, prefer M+M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, - info); - il = iwork; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + info); + il = iwork; /* Copy L to WORK(IL), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen) - 1); - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_((char *)"U", &i__2, &i__1, &c_b46, &c_b46, &work[il + ldwork], & - ldwork, (ftnlen)1); - ie = il + ldwork * *m; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen) + 1); + i__2 = *m - 1; + i__1 = *m - 1; + dlaset_((char *)"U", &i__2, &i__1, &c_b46, &c_b46, &work[il + ldwork], & + ldwork, (ftnlen)1); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IL) */ /* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], - &work[itaup], &work[iwork], &i__2, info); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, info); /* Multiply B by transpose of left bidiagonalizing vectors of L */ /* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[ - itauq], &b[b_offset], ldb, &work[iwork], &i__2, info, ( - ftnlen)1, (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[iwork], &i__2, info, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); /* Generate right bidiagonalizing vectors of R in WORK(IL) */ /* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ - iwork], &i__2, info, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ + iwork], &i__2, info, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, */ /* computing right singular vectors of L in WORK(IL) and */ /* multiplying B by transpose of left singular vectors */ /* (Workspace: need M*M+M+BDSPAC) */ - dbdsqr_((char *)"U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], & - ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork] - , info, (ftnlen)1); - if (*info != 0) { - goto L70; - } + dbdsqr_((char *)"U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], & + ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork] + , info, (ftnlen)1); + if (*info != 0) { + goto L70; + } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { + d__1 = *rcond * s[1]; + thr = max(d__1,sfmin); + if (*rcond < 0.) { /* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1] - , ldb, (ftnlen)1); - } + d__1 = eps * s[1]; + thr = max(d__1,sfmin); + } + *rank = 0; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1] + , ldb, (ftnlen)1); + } /* L30: */ - } - iwork = ie; + } + iwork = ie; /* Multiply B by right singular vectors of L in WORK(IL) */ /* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ - if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { - dgemm_((char *)"T", (char *)"N", m, nrhs, m, &c_b79, &work[il], &ldwork, &b[ - b_offset], ldb, &c_b46, &work[iwork], ldb, (ftnlen)1, - (ftnlen)1); - dlacpy_((char *)"G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb, ( - ftnlen)1); - } else if (*nrhs > 1) { - chunk = (*lwork - iwork + 1) / *m; - i__2 = *nrhs; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { + if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", m, nrhs, m, &c_b79, &work[il], &ldwork, &b[ + b_offset], ldb, &c_b46, &work[iwork], ldb, (ftnlen)1, + (ftnlen)1); + dlacpy_((char *)"G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb, ( + ftnlen)1); + } else if (*nrhs > 1) { + chunk = (*lwork - iwork + 1) / *m; + i__2 = *nrhs; + i__1 = chunk; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__1) { /* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_((char *)"T", (char *)"N", m, &bl, m, &c_b79, &work[il], &ldwork, & - b[i__ * b_dim1 + 1], ldb, &c_b46, &work[iwork], m, - (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] - , ldb, (ftnlen)1); + i__3 = *nrhs - i__ + 1; + bl = min(i__3,chunk); + dgemm_((char *)"T", (char *)"N", m, &bl, m, &c_b79, &work[il], &ldwork, & + b[i__ * b_dim1 + 1], ldb, &c_b46, &work[iwork], m, + (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] + , ldb, (ftnlen)1); /* L40: */ - } - } else { - dgemv_((char *)"T", m, m, &c_b79, &work[il], &ldwork, &b[b_dim1 + 1], - &c__1, &c_b46, &work[iwork], &c__1, (ftnlen)1); - dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); - } + } + } else { + dgemv_((char *)"T", m, m, &c_b79, &work[il], &ldwork, &b[b_dim1 + 1], + &c__1, &c_b46, &work[iwork], &c__1, (ftnlen)1); + dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); + } /* Zero out below first M rows of B */ - i__1 = *n - *m; - dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[*m + 1 + b_dim1], - ldb, (ftnlen)1); - iwork = itau + *m; + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[*m + 1 + b_dim1], + ldb, (ftnlen)1); + iwork = itau + *m; /* Multiply transpose(Q) by B */ /* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ - i__1 = *lwork - iwork + 1; - dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( - ftnlen)1); + i__1 = *lwork - iwork + 1; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, ( + ftnlen)1); - } else { + } else { /* Path 2 - remaining underdetermined cases */ - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize A */ /* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - i__1 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); + i__1 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors */ /* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ - i__1 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq] - , &b[b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, - (ftnlen)1, (ftnlen)1); + i__1 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq] + , &b[b_offset], ldb, &work[iwork], &i__1, info, (ftnlen)1, + (ftnlen)1, (ftnlen)1); /* Generate right bidiagonalizing vectors in A */ /* (Workspace: need 4*M, prefer 3*M+M*NB) */ - i__1 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__1, info, (ftnlen)1); - iwork = ie + *m; + i__1 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__1, info, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, */ /* computing right singular vectors of A in A and */ /* multiplying B by transpose of left singular vectors */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], - lda, dum, &c__1, &b[b_offset], ldb, &work[iwork], info, ( - ftnlen)1); - if (*info != 0) { - goto L70; - } + dbdsqr_((char *)"L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], + lda, dum, &c__1, &b[b_offset], ldb, &work[iwork], info, ( + ftnlen)1); + if (*info != 0) { + goto L70; + } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { + d__1 = *rcond * s[1]; + thr = max(d__1,sfmin); + if (*rcond < 0.) { /* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1] - , ldb, (ftnlen)1); - } + d__1 = eps * s[1]; + thr = max(d__1,sfmin); + } + *rank = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1] + , ldb, (ftnlen)1); + } /* L50: */ - } + } /* Multiply B by right singular vectors of A */ /* (Workspace: need N, prefer N*NRHS) */ - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_((char *)"T", (char *)"N", n, nrhs, m, &c_b79, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b46, &work[1], ldb, (ftnlen)1, ( - ftnlen)1); - dlacpy_((char *)"F", n, nrhs, &work[1], ldb, &b[b_offset], ldb, ( - ftnlen)1); - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", n, nrhs, m, &c_b79, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b46, &work[1], ldb, (ftnlen)1, ( + ftnlen)1); + dlacpy_((char *)"F", n, nrhs, &work[1], ldb, &b[b_offset], ldb, ( + ftnlen)1); + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { /* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_((char *)"T", (char *)"N", n, &bl, m, &c_b79, &a[a_offset], lda, &b[ - i__ * b_dim1 + 1], ldb, &c_b46, &work[1], n, ( - ftnlen)1, (ftnlen)1); - dlacpy_((char *)"F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], - ldb, (ftnlen)1); + i__3 = *nrhs - i__ + 1; + bl = min(i__3,chunk); + dgemm_((char *)"T", (char *)"N", n, &bl, m, &c_b79, &a[a_offset], lda, &b[ + i__ * b_dim1 + 1], ldb, &c_b46, &work[1], n, ( + ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], + ldb, (ftnlen)1); /* L60: */ - } - } else { - dgemv_((char *)"T", m, n, &c_b79, &a[a_offset], lda, &b[b_offset], & - c__1, &c_b46, &work[1], &c__1, (ftnlen)1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } - } + } + } else { + dgemv_((char *)"T", m, n, &c_b79, &a[a_offset], lda, &b[b_offset], & + c__1, &c_b46, &work[1], &c__1, (ftnlen)1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + } } /* Undo scaling */ if (iascl == 1) { - dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info, (ftnlen)1); } else if (iascl == 2) { - dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info, (ftnlen)1); } if (ibscl == 1) { - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); } else if (ibscl == 2) { - dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); } L70: @@ -984,5 +984,5 @@ L70: } /* dgelss_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgemm.cpp b/lib/linalg/dgemm.cpp index 2f59801245..360584e254 100644 --- a/lib/linalg/dgemm.cpp +++ b/lib/linalg/dgemm.cpp @@ -1,13 +1,13 @@ /* fortran/dgemm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -201,13 +201,13 @@ extern "C" { /* > */ /* ===================================================================== */ /* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer * - n, integer *k, doublereal *alpha, doublereal *a, integer *lda, - doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, - integer *ldc, ftnlen transa_len, ftnlen transb_len) + n, integer *k, doublereal *alpha, doublereal *a, integer *lda, + doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, + integer *ldc, ftnlen transa_len, ftnlen transb_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; /* Local variables */ integer i__, j, l, info; @@ -259,192 +259,192 @@ extern "C" { nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1); notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1); if (nota) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *k; + nrowa = *k; } if (notb) { - nrowb = *k; + nrowb = *k; } else { - nrowb = *n; + nrowb = *n; } /* Test the input parameters. */ info = 0; if (! nota && ! lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) && ! lsame_( - transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! notb && ! lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && ! - lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) { - info = 2; + transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! notb && ! lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && ! + lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 2; } else if (*m < 0) { - info = 3; + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*k < 0) { - info = 5; + info = 5; } else if (*lda < max(1,nrowa)) { - info = 8; + info = 8; } else if (*ldb < max(1,nrowb)) { - info = 10; + info = 10; } else if (*ldc < max(1,*m)) { - info = 13; + info = 13; } if (info != 0) { - xerbla_((char *)"DGEMM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DGEMM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; + return 0; } /* And if alpha.eq.zero. */ if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L30: */ - } + } /* L40: */ - } - } - return 0; + } + } + return 0; } /* Start the operations. */ if (notb) { - if (nota) { + if (nota) { /* Form C := alpha*A*B + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L50: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L60: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - temp = *alpha * b[l + j * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + temp = *alpha * b[l + j * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; /* L70: */ - } + } /* L80: */ - } + } /* L90: */ - } - } else { + } + } else { /* Form C := alpha*A**T*B + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; /* L100: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } /* L110: */ - } + } /* L120: */ - } - } + } + } } else { - if (nota) { + if (nota) { /* Form C := alpha*A*B**T + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L130: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L140: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - temp = *alpha * b[j + l * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + temp = *alpha * b[j + l * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; /* L150: */ - } + } /* L160: */ - } + } /* L170: */ - } - } else { + } + } else { /* Form C := alpha*A**T*B**T + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; /* L180: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } /* L190: */ - } + } /* L200: */ - } - } + } + } } return 0; @@ -454,5 +454,5 @@ extern "C" { } /* dgemm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgemv.cpp b/lib/linalg/dgemv.cpp index 1d121c33c0..5e82c1144c 100644 --- a/lib/linalg/dgemv.cpp +++ b/lib/linalg/dgemv.cpp @@ -1,13 +1,13 @@ /* fortran/dgemv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -170,8 +170,8 @@ extern "C" { /* > */ /* ===================================================================== */ /* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal * - alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len) + alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -218,50 +218,50 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"T", ( - ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1) - ) { - info = 1; + ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1) + ) { + info = 1; } else if (*m < 0) { - info = 2; + info = 2; } else if (*n < 0) { - info = 3; + info = 3; } else if (*lda < max(1,*m)) { - info = 6; + info = 6; } else if (*incx == 0) { - info = 8; + info = 8; } else if (*incy == 0) { - info = 11; + info = 11; } if (info != 0) { - xerbla_((char *)"DGEMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DGEMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; + return 0; } /* Set LENX and LENY, the lengths of the vectors x and y, and set */ /* up the start points in X and Y. */ if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - lenx = *n; - leny = *m; + lenx = *n; + leny = *m; } else { - lenx = *m; - leny = *n; + lenx = *m; + leny = *n; } if (*incx > 0) { - kx = 1; + kx = 1; } else { - kx = 1 - (lenx - 1) * *incx; + kx = 1 - (lenx - 1) * *incx; } if (*incy > 0) { - ky = 1; + ky = 1; } else { - ky = 1 - (leny - 1) * *incy; + ky = 1 - (leny - 1) * *incy; } /* Start the operations. In this version the elements of A are */ @@ -270,108 +270,108 @@ extern "C" { /* First form y := beta*y. */ if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; /* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; /* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; /* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; /* L40: */ - } - } - } + } + } + } } if (*alpha == 0.) { - return 0; + return 0; } if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form y := alpha*A*x + y. */ - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha * x[jx]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp * a[i__ + j * a_dim1]; + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; /* L50: */ - } - jx += *incx; + } + jx += *incx; /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha * x[jx]; - iy = ky; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp * a[i__ + j * a_dim1]; - iy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; /* L70: */ - } - jx += *incx; + } + jx += *incx; /* L80: */ - } - } + } + } } else { /* Form y := alpha*A**T*x + y. */ - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; /* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; + } + y[jy] += *alpha * temp; + jy += *incy; /* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; /* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; + } + y[jy] += *alpha * temp; + jy += *incy; /* L120: */ - } - } + } + } } return 0; @@ -381,5 +381,5 @@ extern "C" { } /* dgemv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgeqr2.cpp b/lib/linalg/dgeqr2.cpp index 635e360bc7..6cc1bc8400 100644 --- a/lib/linalg/dgeqr2.cpp +++ b/lib/linalg/dgeqr2.cpp @@ -1,13 +1,13 @@ /* fortran/dgeqr2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -152,7 +152,7 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info) + lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -160,11 +160,11 @@ f"> */ /* Local variables */ integer i__, k; doublereal aii; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -200,16 +200,16 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGEQR2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGEQR2", &i__1, (ftnlen)6); + return 0; } k = min(*m,*n); @@ -219,24 +219,24 @@ f"> */ /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ - i__2 = *m - i__ + 1; + i__2 = *m - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] - , &c__1, &tau[i__]); - if (i__ < *n) { + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] + , &c__1, &tau[i__]); + if (i__ < *n) { /* Apply H(i) to A(i:m,i+1:n) from the left */ - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( - ftnlen)4); - a[i__ + i__ * a_dim1] = aii; - } + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( + ftnlen)4); + a[i__ + i__ * a_dim1] = aii; + } /* L10: */ } return 0; @@ -246,5 +246,5 @@ f"> */ } /* dgeqr2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgeqrf.cpp b/lib/linalg/dgeqrf.cpp index fa0aca3f47..57b92689b9 100644 --- a/lib/linalg/dgeqrf.cpp +++ b/lib/linalg/dgeqrf.cpp @@ -1,13 +1,13 @@ /* fortran/dgeqrf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -170,23 +170,23 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) + lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, k, ib, nb, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, - char *, char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, + char *, char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -225,38 +225,38 @@ f"> */ k = min(*m,*n); *info = 0; nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); + 1); lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } else if (! lquery) { - if (*lwork <= 0 || *m > 0 && *lwork < max(1,*n)) { - *info = -7; - } + if (*lwork <= 0 || *m > 0 && *lwork < max(1,*n)) { + *info = -7; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGEQRF", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGEQRF", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - if (k == 0) { - lwkopt = 1; - } else { - lwkopt = *n * nb; - } - work[1] = (doublereal) lwkopt; - return 0; + if (k == 0) { + lwkopt = 1; + } else { + lwkopt = *n * nb; + } + work[1] = (doublereal) lwkopt; + return 0; } /* Quick return if possible */ if (k == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; @@ -267,79 +267,79 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < k && nx < k) { /* Use blocked code initially */ - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__3 = k - i__ + 1; - ib = min(i__3,nb); + i__3 = k - i__ + 1; + ib = min(i__3,nb); /* Compute the QR factorization of the current block */ /* A(i:m,i:i+ib-1) */ - i__3 = *m - i__ + 1; - dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ - 1], &iinfo); - if (i__ + ib <= *n) { + i__3 = *m - i__ + 1; + dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__3 = *m - i__ + 1; - dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, - (ftnlen)10); + i__3 = *m - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, + (ftnlen)10); /* Apply H**T to A(i:m,i+ib:n) from the left */ - i__3 = *m - i__ + 1; - i__4 = *n - i__ - ib + 1; - dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, & - i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib - + 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, ( - ftnlen)10); - } + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, & + i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + + 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, ( + ftnlen)10); + } /* L10: */ - } + } } else { - i__ = 1; + i__ = 1; } /* Use unblocked code to factor the last or only block. */ if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] - , &iinfo); + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] + , &iinfo); } work[1] = (doublereal) iws; @@ -350,5 +350,5 @@ f"> */ } /* dgeqrf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dger.cpp b/lib/linalg/dger.cpp index fd5c4940bf..9bb0d19982 100644 --- a/lib/linalg/dger.cpp +++ b/lib/linalg/dger.cpp @@ -1,13 +1,13 @@ /* fortran/dger.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -143,9 +143,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda) +/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *y, integer *incy, + doublereal *a, integer *lda) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -188,70 +188,70 @@ extern "C" { /* Function Body */ info = 0; if (*m < 0) { - info = 1; + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*incx == 0) { - info = 5; + info = 5; } else if (*incy == 0) { - info = 7; + info = 7; } else if (*lda < max(1,*m)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"DGER ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DGER ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || *alpha == 0.) { - return 0; + return 0; } /* Start the operations. In this version the elements of A are */ /* accessed sequentially with one pass through A. */ if (*incy > 0) { - jy = 1; + jy = 1; } else { - jy = 1 - (*n - 1) * *incy; + jy = 1 - (*n - 1) * *incy; } if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; /* L10: */ - } - } - jy += *incy; + } + } + jy += *incy; /* L20: */ - } + } } else { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*m - 1) * *incx; - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; /* L30: */ - } - } - jy += *incy; + } + } + jy += *incy; /* L40: */ - } + } } return 0; @@ -261,5 +261,5 @@ extern "C" { } /* dger_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgesv.cpp b/lib/linalg/dgesv.cpp index a71b2caa68..c2e0232c37 100644 --- a/lib/linalg/dgesv.cpp +++ b/lib/linalg/dgesv.cpp @@ -1,13 +1,13 @@ /* fortran/dgesv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -138,17 +138,17 @@ extern "C" { /* > \ingroup doubleGEsolve */ /* ===================================================================== */ -/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer - *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info) +/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer + *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; /* Local variables */ - extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen), dgetrs_(char *, integer *, integer *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *, ftnlen); + extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen), dgetrs_(char *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *, ftnlen); /* -- LAPACK driver routine -- */ @@ -182,18 +182,18 @@ extern "C" { /* Function Body */ *info = 0; if (*n < 0) { - *info = -1; + *info = -1; } else if (*nrhs < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else if (*ldb < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGESV ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGESV ", &i__1, (ftnlen)6); + return 0; } /* Compute the LU factorization of A. */ @@ -203,8 +203,8 @@ extern "C" { /* Solve the system A*X = B, overwriting B with X. */ - dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ - b_offset], ldb, info, (ftnlen)12); + dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ + b_offset], ldb, info, (ftnlen)12); } return 0; @@ -213,5 +213,5 @@ extern "C" { } /* dgesv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgesvd.cpp b/lib/linalg/dgesvd.cpp index 96fd8735b0..6a2e70640f 100644 --- a/lib/linalg/dgesvd.cpp +++ b/lib/linalg/dgesvd.cpp @@ -1,13 +1,13 @@ /* fortran/dgesvd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -236,15 +236,15 @@ f"> */ /* > \ingroup doubleGEsing */ /* ===================================================================== */ -/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, - doublereal *a, integer *lda, doublereal *s, doublereal *u, integer * - ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *info, ftnlen jobu_len, ftnlen jobvt_len) +/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, + doublereal *a, integer *lda, doublereal *s, doublereal *u, integer * + ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, + integer *info, ftnlen jobu_len, ftnlen jobvt_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], - i__2, i__3, i__4; + integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], + i__2, i__3, i__4; char ch__1[2]; /* Builtin functions */ @@ -256,51 +256,51 @@ f"> */ doublereal dum[1], eps; integer nru, iscl; doublereal anrm; - integer ierr, itau, ncvt, nrvt, lwork_dgebrd__, lwork_dgelqf__, - lwork_dgeqrf__; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + integer ierr, itau, ncvt, nrvt, lwork_dgebrd__, lwork_dgelqf__, + lwork_dgeqrf__; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork; logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs; - extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *); - extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, ftnlen); + extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *); + extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, ftnlen); integer bdspac; - extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *), - dlascl_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *, ftnlen), - dgeqrf_(integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *, ftnlen), dlaset_(char *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, ftnlen), - dbdsqr_(char *, integer *, integer *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen), dorgbr_(char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *, ftnlen); + extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlascl_(char *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *, ftnlen), + dgeqrf_(integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen), dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, ftnlen), + dbdsqr_(char *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), dorgbr_(char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *, ftnlen); doublereal bignum; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *, - ftnlen, ftnlen, ftnlen), dorglq_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *), dorgqr_(integer *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen, ftnlen), dorglq_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *), dorgqr_(integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *); integer ldwrkr, minwrk, ldwrku, maxwrk; doublereal smlnum; logical lquery, wntuas, wntvas; - integer lwork_dorgbr_p__, lwork_dorgbr_q__, lwork_dorglq_m__, - lwork_dorglq_n__, lwork_dorgqr_m__, lwork_dorgqr_n__; + integer lwork_dorgbr_p__, lwork_dorgbr_q__, lwork_dorglq_m__, + lwork_dorglq_n__, lwork_dorgqr_m__, lwork_dorgqr_n__; /* -- LAPACK driver routine -- */ @@ -359,19 +359,19 @@ f"> */ lquery = *lwork == -1; if (! (wntua || wntus || wntuo || wntun)) { - *info = -1; + *info = -1; } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*lda < max(1,*m)) { - *info = -6; + *info = -6; } else if (*ldu < 1 || wntuas && *ldu < *m) { - *info = -9; + *info = -9; } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) { - *info = -11; + *info = -11; } /* Compute workspace */ @@ -382,547 +382,547 @@ f"> */ /* following subroutine, as returned by ILAENV.) */ if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (*m >= *n && minmn > 0) { + minwrk = 1; + maxwrk = 1; + if (*m >= *n && minmn > 0) { /* Compute space needed for DBDSQR */ /* Writing concatenation */ - i__1[0] = 1, a__1[0] = jobu; - i__1[1] = 1, a__1[1] = jobvt; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, ( - ftnlen)6, (ftnlen)2); - bdspac = *n * 5; + i__1[0] = 1, a__1[0] = jobu; + i__1[1] = 1, a__1[1] = jobvt; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, ( + ftnlen)6, (ftnlen)2); + bdspac = *n * 5; /* Compute space needed for DGEQRF */ - dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); - lwork_dgeqrf__ = (integer) dum[0]; + dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dgeqrf__ = (integer) dum[0]; /* Compute space needed for DORGQR */ - dorgqr_(m, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); - lwork_dorgqr_n__ = (integer) dum[0]; - dorgqr_(m, m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); - lwork_dorgqr_m__ = (integer) dum[0]; + dorgqr_(m, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorgqr_n__ = (integer) dum[0]; + dorgqr_(m, m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorgqr_m__ = (integer) dum[0]; /* Compute space needed for DGEBRD */ - dgebrd_(n, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, - &ierr); - lwork_dgebrd__ = (integer) dum[0]; + dgebrd_(n, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, + &ierr); + lwork_dgebrd__ = (integer) dum[0]; /* Compute space needed for DORGBR P */ - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, ( - ftnlen)1); - lwork_dorgbr_p__ = (integer) dum[0]; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, ( + ftnlen)1); + lwork_dorgbr_p__ = (integer) dum[0]; /* Compute space needed for DORGBR Q */ - dorgbr_((char *)"Q", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, ( - ftnlen)1); - lwork_dorgbr_q__ = (integer) dum[0]; + dorgbr_((char *)"Q", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, ( + ftnlen)1); + lwork_dorgbr_q__ = (integer) dum[0]; - if (*m >= mnthr) { - if (wntun) { + if (*m >= mnthr) { + if (wntun) { /* Path 1 (M much larger than N, JOBU='N') */ - maxwrk = *n + lwork_dgeqrf__; + maxwrk = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + lwork_dgebrd__; - maxwrk = max(i__2,i__3); - if (wntvo || wntvas) { + i__2 = maxwrk, i__3 = *n * 3 + lwork_dgebrd__; + maxwrk = max(i__2,i__3); + if (wntvo || wntvas) { /* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; - maxwrk = max(i__2,i__3); - } - maxwrk = max(maxwrk,bdspac); + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2,i__3); + } + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__2 = *n << 2; - minwrk = max(i__2,bdspac); - } else if (wntuo && wntvn) { + i__2 = *n << 2; + minwrk = max(i__2,bdspac); + } else if (wntuo && wntvn) { /* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); /* Computing MAX */ - i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; - maxwrk = max(i__2,i__3); + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = max(i__2,i__3); /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntuo && wntvas) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntuo && wntvas) { /* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */ /* 'A') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); /* Computing MAX */ - i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; - maxwrk = max(i__2,i__3); + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = max(i__2,i__3); /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntus && wntvn) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntus && wntvn) { /* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntus && wntvo) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntus && wntvo) { /* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = (*n << 1) * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = (*n << 1) * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntus && wntvas) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntus && wntvas) { /* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */ /* 'A') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntua && wntvn) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntua && wntvn) { /* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntua && wntvo) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntua && wntvo) { /* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = (*n << 1) * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = (*n << 1) * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } else if (wntua && wntvas) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } else if (wntua && wntvas) { /* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */ /* 'A') */ - wrkbl = *n + lwork_dgeqrf__; + wrkbl = *n + lwork_dgeqrf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } - } else { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } + } else { /* Path 10 (M at least N, but not much larger) */ - dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, & - c_n1, &ierr); - lwork_dgebrd__ = (integer) dum[0]; - maxwrk = *n * 3 + lwork_dgebrd__; - if (wntus || wntuo) { - dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, dum, dum, &c_n1, - &ierr, (ftnlen)1); - lwork_dorgbr_q__ = (integer) dum[0]; + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, & + c_n1, &ierr); + lwork_dgebrd__ = (integer) dum[0]; + maxwrk = *n * 3 + lwork_dgebrd__; + if (wntus || wntuo) { + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, dum, dum, &c_n1, + &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer) dum[0]; /* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; - maxwrk = max(i__2,i__3); - } - if (wntua) { - dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, dum, dum, &c_n1, - &ierr, (ftnlen)1); - lwork_dorgbr_q__ = (integer) dum[0]; + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2,i__3); + } + if (wntua) { + dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, dum, dum, &c_n1, + &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer) dum[0]; /* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; - maxwrk = max(i__2,i__3); - } - if (! wntvn) { + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2,i__3); + } + if (! wntvn) { /* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; - maxwrk = max(i__2,i__3); - } - maxwrk = max(maxwrk,bdspac); + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2,i__3); + } + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = max(i__2,bdspac); - } - } else if (minmn > 0) { + i__2 = *n * 3 + *m; + minwrk = max(i__2,bdspac); + } + } else if (minmn > 0) { /* Compute space needed for DBDSQR */ /* Writing concatenation */ - i__1[0] = 1, a__1[0] = jobu; - i__1[1] = 1, a__1[1] = jobvt; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, ( - ftnlen)6, (ftnlen)2); - bdspac = *m * 5; + i__1[0] = 1, a__1[0] = jobu; + i__1[1] = 1, a__1[1] = jobvt; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, ( + ftnlen)6, (ftnlen)2); + bdspac = *m * 5; /* Compute space needed for DGELQF */ - dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); - lwork_dgelqf__ = (integer) dum[0]; + dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dgelqf__ = (integer) dum[0]; /* Compute space needed for DORGLQ */ - dorglq_(n, n, m, dum, n, dum, dum, &c_n1, &ierr); - lwork_dorglq_n__ = (integer) dum[0]; - dorglq_(m, n, m, &a[a_offset], lda, dum, dum, &c_n1, &ierr); - lwork_dorglq_m__ = (integer) dum[0]; + dorglq_(n, n, m, dum, n, dum, dum, &c_n1, &ierr); + lwork_dorglq_n__ = (integer) dum[0]; + dorglq_(m, n, m, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorglq_m__ = (integer) dum[0]; /* Compute space needed for DGEBRD */ - dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, - &ierr); - lwork_dgebrd__ = (integer) dum[0]; + dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, + &ierr); + lwork_dgebrd__ = (integer) dum[0]; /* Compute space needed for DORGBR P */ - dorgbr_((char *)"P", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, ( - ftnlen)1); - lwork_dorgbr_p__ = (integer) dum[0]; + dorgbr_((char *)"P", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, ( + ftnlen)1); + lwork_dorgbr_p__ = (integer) dum[0]; /* Compute space needed for DORGBR Q */ - dorgbr_((char *)"Q", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, ( - ftnlen)1); - lwork_dorgbr_q__ = (integer) dum[0]; - if (*n >= mnthr) { - if (wntvn) { + dorgbr_((char *)"Q", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, ( + ftnlen)1); + lwork_dorgbr_q__ = (integer) dum[0]; + if (*n >= mnthr) { + if (wntvn) { /* Path 1t(N much larger than M, JOBVT='N') */ - maxwrk = *m + lwork_dgelqf__; + maxwrk = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + lwork_dgebrd__; - maxwrk = max(i__2,i__3); - if (wntuo || wntuas) { + i__2 = maxwrk, i__3 = *m * 3 + lwork_dgebrd__; + maxwrk = max(i__2,i__3); + if (wntuo || wntuas) { /* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; - maxwrk = max(i__2,i__3); - } - maxwrk = max(maxwrk,bdspac); + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2,i__3); + } + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__2 = *m << 2; - minwrk = max(i__2,bdspac); - } else if (wntvo && wntun) { + i__2 = *m << 2; + minwrk = max(i__2,bdspac); + } else if (wntvo && wntun) { /* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); /* Computing MAX */ - i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; - maxwrk = max(i__2,i__3); + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = max(i__2,i__3); /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntvo && wntuas) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntvo && wntuas) { /* Path 3t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='O') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); /* Computing MAX */ - i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; - maxwrk = max(i__2,i__3); + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = max(i__2,i__3); /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntvs && wntun) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntvs && wntun) { /* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntvs && wntuo) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntvs && wntuo) { /* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = (*m << 1) * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = (*m << 1) * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntvs && wntuas) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntvs && wntuas) { /* Path 6t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='S') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntva && wntun) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntva && wntun) { /* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntva && wntuo) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntva && wntuo) { /* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = (*m << 1) * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = (*m << 1) * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } else if (wntva && wntuas) { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } else if (wntva && wntuas) { /* Path 9t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='A') */ - wrkbl = *m + lwork_dgelqf__; + wrkbl = *m + lwork_dgelqf__; /* Computing MAX */ - i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; - wrkbl = max(i__2,i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2,i__3); /* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; - wrkbl = max(i__2,i__3); - wrkbl = max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2,i__3); + wrkbl = max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } - } else { + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } + } else { /* Path 10t(N greater than M, but not much larger) */ - dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, & - c_n1, &ierr); - lwork_dgebrd__ = (integer) dum[0]; - maxwrk = *m * 3 + lwork_dgebrd__; - if (wntvs || wntvo) { + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, & + c_n1, &ierr); + lwork_dgebrd__ = (integer) dum[0]; + maxwrk = *m * 3 + lwork_dgebrd__; + if (wntvs || wntvo) { /* Compute space needed for DORGBR P */ - dorgbr_((char *)"P", m, n, m, &a[a_offset], n, dum, dum, &c_n1, & - ierr, (ftnlen)1); - lwork_dorgbr_p__ = (integer) dum[0]; + dorgbr_((char *)"P", m, n, m, &a[a_offset], n, dum, dum, &c_n1, & + ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer) dum[0]; /* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; - maxwrk = max(i__2,i__3); - } - if (wntva) { - dorgbr_((char *)"P", n, n, m, &a[a_offset], n, dum, dum, &c_n1, & - ierr, (ftnlen)1); - lwork_dorgbr_p__ = (integer) dum[0]; + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2,i__3); + } + if (wntva) { + dorgbr_((char *)"P", n, n, m, &a[a_offset], n, dum, dum, &c_n1, & + ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer) dum[0]; /* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; - maxwrk = max(i__2,i__3); - } - if (! wntun) { + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2,i__3); + } + if (! wntun) { /* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; - maxwrk = max(i__2,i__3); - } - maxwrk = max(maxwrk,bdspac); + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2,i__3); + } + maxwrk = max(maxwrk,bdspac); /* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = max(i__2,bdspac); - } - } - maxwrk = max(maxwrk,minwrk); - work[1] = (doublereal) maxwrk; + i__2 = *m * 3 + *n; + minwrk = max(i__2,bdspac); + } + } + maxwrk = max(maxwrk,minwrk); + work[1] = (doublereal) maxwrk; - if (*lwork < minwrk && ! lquery) { - *info = -13; - } + if (*lwork < minwrk && ! lquery) { + *info = -13; + } } if (*info != 0) { - i__2 = -(*info); - xerbla_((char *)"DGESVD", &i__2, (ftnlen)6); - return 0; + i__2 = -(*info); + xerbla_((char *)"DGESVD", &i__2, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* Get machine constants */ @@ -936,13 +936,13 @@ f"> */ anrm = dlange_((char *)"M", m, n, &a[a_offset], lda, dum, (ftnlen)1); iscl = 0; if (anrm > 0. && anrm < smlnum) { - iscl = 1; - dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & - ierr, (ftnlen)1); + iscl = 1; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & + ierr, (ftnlen)1); } else if (anrm > bignum) { - iscl = 1; - dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & - ierr, (ftnlen)1); + iscl = 1; + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & + ierr, (ftnlen)1); } if (*m >= *n) { @@ -951,751 +951,751 @@ f"> */ /* more rows than columns, first reduce using the QR */ /* decomposition (if sufficient workspace available) */ - if (*m >= mnthr) { + if (*m >= mnthr) { - if (wntun) { + if (wntun) { /* Path 1 (M much larger than N, JOBU='N') */ /* No left singular vectors to be computed */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & + i__2, &ierr); /* Zero out below R */ - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], - lda, (ftnlen)1); - } - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], + lda, (ftnlen)1); + } + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in A */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - ncvt = 0; - if (wntvo || wntvas) { + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + ncvt = 0; + if (wntvo || wntvas) { /* If right singular vectors desired, generate P'. */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], & - work[iwork], &i__2, &ierr, (ftnlen)1); - ncvt = *n; - } - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], & + work[iwork], &i__2, &ierr, (ftnlen)1); + ncvt = *n; + } + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in A if desired */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork], - info, (ftnlen)1); + dbdsqr_((char *)"U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork], + info, (ftnlen)1); /* If right singular vectors desired in VT, copy them there */ - if (wntvas) { - dlacpy_((char *)"F", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); - } + if (wntvas) { + dlacpy_((char *)"F", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); + } - } else if (wntuo && wntvn) { + } else if (wntuo && wntvn) { /* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ /* N left singular vectors to be overwritten on A and */ /* no right singular vectors to be computed */ /* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + max(i__2,bdspac)) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; + ir = 1; /* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *n; - if (*lwork >= max(i__2,i__3) + *lda * *n) { + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= max(i__2,i__3) + *lda * *n) { /* WORK(IU) is LDA by N, WORK(IR) is LDA by N */ - ldwrku = *lda; - ldwrkr = *lda; - } else /* if(complicated condition) */ { + ldwrku = *lda; + ldwrkr = *lda; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *n; - if (*lwork >= max(i__2,i__3) + *n * *n) { + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= max(i__2,i__3) + *n * *n) { /* WORK(IU) is LDA by N, WORK(IR) is N by N */ - ldwrku = *lda; - ldwrkr = *n; - } else { + ldwrku = *lda; + ldwrkr = *n; + } else { /* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */ - ldwrku = (*lwork - *n * *n - *n) / *n; - ldwrkr = *n; - } - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__2, &ierr); /* Copy R to WORK(IR) and zero out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, - (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + 1], - &ldwrkr, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, + (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + 1], + &ldwrkr, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); /* Generate left vectors bidiagonalizing R */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & - work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & + work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR) */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, & - c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork] - , info, (ftnlen)1); - iu = ie + *n; + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, & + c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork] + , info, (ftnlen)1); + iu = ie + *n; /* Multiply Q in A by left singular vectors of R in */ /* WORK(IR), storing result in WORK(IU) and copying to A */ /* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) */ - i__2 = *m; - i__3 = ldwrku; - for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__3) { + i__2 = *m; + i__3 = ldwrku; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__3) { /* Computing MIN */ - i__4 = *m - i__ + 1; - chunk = min(i__4,ldwrku); - dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + - a_dim1], lda, &work[ir], &ldwrkr, &c_b57, & - work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + - a_dim1], lda, (ftnlen)1); + i__4 = *m - i__ + 1; + chunk = min(i__4,ldwrku); + dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + + a_dim1], lda, &work[ir], &ldwrkr, &c_b57, & + work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + + a_dim1], lda, (ftnlen)1); /* L10: */ - } + } - } else { + } else { /* Insufficient workspace for a fast algorithm */ - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize A */ /* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) */ - i__3 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); /* Generate left vectors bidiagonalizing A */ /* (Workspace: need 4*N, prefer 3*N + N*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], & - work[iwork], &i__3, &ierr, (ftnlen)1); - iwork = ie + *n; + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], & + work[iwork], &i__3, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, & - c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], - info, (ftnlen)1); + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, & + c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], + info, (ftnlen)1); - } + } - } else if (wntuo && wntvas) { + } else if (wntuo && wntvas) { /* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */ /* N left singular vectors to be overwritten on A and */ /* N right singular vectors to be computed in VT */ /* Computing MAX */ - i__3 = *n << 2; - if (*lwork >= *n * *n + max(i__3,bdspac)) { + i__3 = *n << 2; + if (*lwork >= *n * *n + max(i__3,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; + ir = 1; /* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *n; - if (*lwork >= max(i__3,i__2) + *lda * *n) { + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= max(i__3,i__2) + *lda * *n) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - ldwrku = *lda; - ldwrkr = *lda; - } else /* if(complicated condition) */ { + ldwrku = *lda; + ldwrkr = *lda; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *n; - if (*lwork >= max(i__3,i__2) + *n * *n) { + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= max(i__3,i__2) + *n * *n) { /* WORK(IU) is LDA by N and WORK(IR) is N by N */ - ldwrku = *lda; - ldwrkr = *n; - } else { + ldwrku = *lda; + ldwrkr = *n; + } else { /* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */ - ldwrku = (*lwork - *n * *n - *n) / *n; - ldwrkr = *n; - } - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__3 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__3, &ierr); /* Copy R to VT, zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); - if (*n > 1) { - i__3 = *n - 1; - i__2 = *n - 1; - dlaset_((char *)"L", &i__3, &i__2, &c_b57, &c_b57, &vt[ - vt_dim1 + 2], ldvt, (ftnlen)1); - } + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); + if (*n > 1) { + i__3 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__3, &i__2, &c_b57, &c_b57, &vt[ + vt_dim1 + 2], ldvt, (ftnlen)1); + } /* Generate Q in A */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__3 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__3, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__3 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in VT, copying result to WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__3 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], &i__3, & - ierr); - dlacpy_((char *)"L", n, n, &vt[vt_offset], ldvt, &work[ir], & - ldwrkr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], &i__3, & + ierr); + dlacpy_((char *)"L", n, n, &vt[vt_offset], ldvt, &work[ir], & + ldwrkr, (ftnlen)1); /* Generate left vectors bidiagonalizing R in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & - work[iwork], &i__3, &ierr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & + work[iwork], &i__3, &ierr, (ftnlen)1); /* Generate right vectors bidiagonalizing R in VT */ /* (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__3, &ierr, (ftnlen)1); - iwork = ie + *n; + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__3, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR) and computing right */ /* singular vectors of R in VT */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info, (ftnlen)1); - iu = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info, (ftnlen)1); + iu = ie + *n; /* Multiply Q in A by left singular vectors of R in */ /* WORK(IR), storing result in WORK(IU) and copying to A */ /* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) */ - i__3 = *m; - i__2 = ldwrku; - for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += - i__2) { + i__3 = *m; + i__2 = ldwrku; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += + i__2) { /* Computing MIN */ - i__4 = *m - i__ + 1; - chunk = min(i__4,ldwrku); - dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + - a_dim1], lda, &work[ir], &ldwrkr, &c_b57, & - work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + - a_dim1], lda, (ftnlen)1); + i__4 = *m - i__ + 1; + chunk = min(i__4,ldwrku); + dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + + a_dim1], lda, &work[ir], &ldwrkr, &c_b57, & + work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + + a_dim1], lda, (ftnlen)1); /* L20: */ - } + } - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__2, &ierr); /* Copy R to VT, zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ - vt_dim1 + 2], ldvt, (ftnlen)1); - } + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ + vt_dim1 + 2], ldvt, (ftnlen)1); + } /* Generate Q in A */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], &i__2, & - ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], &i__2, & + ierr); /* Multiply Q in A by left vectors bidiagonalizing R */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, & - work[itauq], &a[a_offset], lda, &work[iwork], & - i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, & + work[itauq], &a[a_offset], lda, &work[iwork], & + i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1); /* Generate right vectors bidiagonalizing R in VT */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in A and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntus) { + } else if (wntus) { - if (wntvn) { + if (wntvn) { /* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ /* N left singular vectors to be computed in U and */ /* no right singular vectors to be computed */ /* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + max(i__2,bdspac)) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; - if (*lwork >= wrkbl + *lda * *n) { + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { /* WORK(IR) is LDA by N */ - ldwrkr = *lda; - } else { + ldwrkr = *lda; + } else { /* WORK(IR) is N by N */ - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy R to WORK(IR), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], & - ldwrkr, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + - 1], &ldwrkr, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], & + ldwrkr, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + + 1], &ldwrkr, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Generate left vectors bidiagonalizing R in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR) */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], - dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], + dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IR), storing result in U */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & - work[ir], &ldwrkr, &c_b57, &u[u_offset], ldu, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & + work[ir], &ldwrkr, &c_b57, &u[u_offset], ldu, + (ftnlen)1, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Zero out below R in A */ - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ - a_dim1 + 2], lda, (ftnlen)1); - } + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ + a_dim1 + 2], lda, (ftnlen)1); + } /* Bidiagonalize R in A */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left vectors bidiagonalizing R */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], - dum, &c__1, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], + dum, &c__1, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntvo) { + } else if (wntvo) { /* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ /* N left singular vectors to be computed in U and */ /* N right singular vectors to be overwritten on A */ /* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) { + i__2 = *n << 2; + if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *n) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is N by N */ - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } else { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { /* WORK(IU) is N by N and WORK(IR) is N by N */ - ldwrku = *n; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - 1], &ldwrku, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + 1], &ldwrku, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), copying result to */ /* WORK(IR) */ /* (Workspace: need 2*N*N + 4*N, */ /* prefer 2*N*N+3*N+2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], & - ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], & + ldwrkr, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need 2*N*N + 4*N-1, */ /* prefer 2*N*N+3*N+(N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU) and computing */ /* right singular vectors of R in WORK(IR) */ /* (Workspace: need 2*N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, + &work[iwork], info, (ftnlen)1); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IU), storing result in U */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & - work[iu], &ldwrku, &c_b57, &u[u_offset], ldu, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & + work[iu], &ldwrku, &c_b57, &u[u_offset], ldu, + (ftnlen)1, (ftnlen)1); /* Copy right singular vectors of R to A */ /* (Workspace: need N*N) */ - dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], - lda, (ftnlen)1); + dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], + lda, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Zero out below R in A */ - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ - a_dim1 + 2], lda, (ftnlen)1); - } + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ + a_dim1 + 2], lda, (ftnlen)1); + } /* Bidiagonalize R in A */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left vectors bidiagonalizing R */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) - ; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) + ; /* Generate right vectors bidiagonalizing R in A */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, + &work[iwork], info, (ftnlen)1); - } + } - } else if (wntvas) { + } else if (wntvas) { /* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */ /* or 'A') */ @@ -1703,531 +1703,531 @@ f"> */ /* N right singular vectors to be computed in VT */ /* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + max(i__2,bdspac)) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + *lda * *n) { + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { /* WORK(IU) is LDA by N */ - ldwrku = *lda; - } else { + ldwrku = *lda; + } else { /* WORK(IU) is N by N */ - ldwrku = *n; - } - itau = iu + ldwrku * *n; - iwork = itau + *n; + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; /* Compute A=Q*R */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - 1], &ldwrku, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + 1], &ldwrku, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), copying result to VT */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate right bidiagonalizing vectors in VT */ /* (Workspace: need N*N + 4*N-1, */ /* prefer N*N+3*N+(N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU) and computing */ /* right singular vectors of R in VT */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[iu], &ldwrku, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[iu], &ldwrku, dum, & + c__1, &work[iwork], info, (ftnlen)1); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IU), storing result in U */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & - work[iu], &ldwrku, &c_b57, &u[u_offset], ldu, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, & + work[iu], &ldwrku, &c_b57, &u[u_offset], ldu, + (ftnlen)1, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy R to VT, zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ - vt_dim1 + 2], ldvt, (ftnlen)1); - } - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ + vt_dim1 + 2], ldvt, (ftnlen)1); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], - &work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], + &work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left bidiagonalizing vectors */ /* in VT */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, - &work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen) - 1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, + &work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen) + 1); /* Generate right bidiagonalizing vectors in VT */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } + } - } else if (wntua) { + } else if (wntua) { - if (wntvn) { + if (wntvn) { /* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ /* M left singular vectors to be computed in U and */ /* no right singular vectors to be computed */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); - if (*lwork >= *n * *n + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); + if (*lwork >= *n * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; - if (*lwork >= wrkbl + *lda * *n) { + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { /* WORK(IR) is LDA by N */ - ldwrkr = *lda; - } else { + ldwrkr = *lda; + } else { /* WORK(IR) is N by N */ - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Copy R to WORK(IR), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], & - ldwrkr, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + - 1], &ldwrkr, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], & + ldwrkr, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + + 1], &ldwrkr, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Generate left bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR) */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], - dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], + dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IR), storing result in A */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & - work[ir], &ldwrkr, &c_b57, &a[a_offset], lda, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & + work[ir], &ldwrkr, &c_b57, &a[a_offset], lda, + (ftnlen)1, (ftnlen)1); /* Copy left singular vectors of A from A to U */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need N + M, prefer N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Zero out below R in A */ - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ - a_dim1 + 2], lda, (ftnlen)1); - } + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ + a_dim1 + 2], lda, (ftnlen)1); + } /* Bidiagonalize R in A */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left bidiagonalizing vectors */ /* in A */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], - dum, &c__1, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], + dum, &c__1, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntvo) { + } else if (wntvo) { /* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ /* M left singular vectors to be computed in U and */ /* N right singular vectors to be overwritten on A */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); - if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); + if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *n) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is N by N */ - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } else { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { /* WORK(IU) is N by N and WORK(IR) is N by N */ - ldwrku = *n; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - 1], &ldwrku, (ftnlen)1); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + 1], &ldwrku, (ftnlen)1); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), copying result to */ /* WORK(IR) */ /* (Workspace: need 2*N*N + 4*N, */ /* prefer 2*N*N+3*N+2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], & - ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], & + ldwrkr, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need 2*N*N + 4*N-1, */ /* prefer 2*N*N+3*N+(N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU) and computing */ /* right singular vectors of R in WORK(IR) */ /* (Workspace: need 2*N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, + &work[iwork], info, (ftnlen)1); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IU), storing result in A */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & - work[iu], &ldwrku, &c_b57, &a[a_offset], lda, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & + work[iu], &ldwrku, &c_b57, &a[a_offset], lda, + (ftnlen)1, (ftnlen)1); /* Copy left singular vectors of A from A to U */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Copy right singular vectors of R from WORK(IR) to A */ - dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], - lda, (ftnlen)1); + dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], + lda, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need N + M, prefer N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Zero out below R in A */ - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ - a_dim1 + 2], lda, (ftnlen)1); - } + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[ + a_dim1 + 2], lda, (ftnlen)1); + } /* Bidiagonalize R in A */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left bidiagonalizing vectors */ /* in A */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) - ; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1) + ; /* Generate right bidiagonalizing vectors in A */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, + &work[iwork], info, (ftnlen)1); - } + } - } else if (wntvas) { + } else if (wntvas) { /* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */ /* or 'A') */ @@ -2235,298 +2235,298 @@ f"> */ /* N right singular vectors to be computed in VT */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); - if (*lwork >= *n * *n + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3); + if (*lwork >= *n * *n + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + *lda * *n) { + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { /* WORK(IU) is LDA by N */ - ldwrku = *lda; - } else { + ldwrku = *lda; + } else { /* WORK(IU) is N by N */ - ldwrku = *n; - } - itau = iu + ldwrku * *n; - iwork = itau + *n; + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - 1], &ldwrku, (ftnlen)1); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + 1], &ldwrku, (ftnlen)1); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), copying result to VT */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate right bidiagonalizing vectors in VT */ /* (Workspace: need N*N + 4*N-1, */ /* prefer N*N+3*N+(N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU) and computing */ /* right singular vectors of R in VT */ /* (Workspace: need N*N + BDSPAC) */ - dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[iu], &ldwrku, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[iu], &ldwrku, dum, & + c__1, &work[iwork], info, (ftnlen)1); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IU), storing result in A */ /* (Workspace: need N*N) */ - dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & - work[iu], &ldwrku, &c_b57, &a[a_offset], lda, - (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, & + work[iu], &ldwrku, &c_b57, &a[a_offset], lda, + (ftnlen)1, (ftnlen)1); /* Copy left singular vectors of A from A to U */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *n; + itau = 1; + iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (Workspace: need 2*N, prefer N + N*NB) */ - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); /* Generate Q in U */ /* (Workspace: need N + M, prefer N + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy R from A to VT, zeroing out below it */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ - vt_dim1 + 2], ldvt, (ftnlen)1); - } - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[ + vt_dim1 + 2], ldvt, (ftnlen)1); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (Workspace: need 4*N, prefer 3*N + 2*N*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], - &work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], + &work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply Q in U by left bidiagonalizing vectors */ /* in VT */ /* (Workspace: need 3*N + M, prefer 3*N + M*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, - &work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen) - 1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, + &work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen) + 1); /* Generate right bidiagonalizing vectors in VT */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) - ; - iwork = ie + *n; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr, (ftnlen)1) + ; + iwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } + } - } + } - } else { + } else { /* M .LT. MNTHR */ /* Path 10 (M at least N, but not much larger) */ /* Reduce to bidiagonal form without QR decomposition */ - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; /* Bidiagonalize A */ /* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__2, &ierr); - if (wntuas) { + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__2, &ierr); + if (wntuas) { /* If left singular vectors desired in U, copy result to U */ /* and generate left bidiagonalizing vectors in U */ /* (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB) */ - dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, ( - ftnlen)1); - if (wntus) { - ncu = *n; - } - if (wntua) { - ncu = *m; - } - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntvas) { + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, ( + ftnlen)1); + if (wntus) { + ncu = *n; + } + if (wntua) { + ncu = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntvas) { /* If right singular vectors desired in VT, copy result to */ /* VT and generate right bidiagonalizing vectors in VT */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, ( - ftnlen)1); - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], & - work[iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntuo) { + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, ( + ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], & + work[iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntuo) { /* If left singular vectors desired in A, generate left */ /* bidiagonalizing vectors in A */ /* (Workspace: need 4*N, prefer 3*N + N*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[ - iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[ + iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntvo) { /* If right singular vectors desired in A, generate right */ /* bidiagonalizing vectors in A */ /* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__2, &ierr, (ftnlen)1); - } - iwork = ie + *n; - if (wntuas || wntuo) { - nru = *m; - } - if (wntun) { - nru = 0; - } - if (wntvas || wntvo) { - ncvt = *n; - } - if (wntvn) { - ncvt = 0; - } - if (! wntuo && ! wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__2, &ierr, (ftnlen)1); + } + iwork = ie + *n; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (! wntuo && ! wntvo) { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in U and computing right singular */ /* vectors in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); - } else if (! wntuo && wntvo) { + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); + } else if (! wntuo && wntvo) { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in U and computing right singular */ /* vectors in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info, (ftnlen)1); - } else { + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info, (ftnlen)1); + } else { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in A and computing right singular */ /* vectors in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info, (ftnlen)1); - } + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info, (ftnlen)1); + } - } + } } else { @@ -2534,751 +2534,751 @@ f"> */ /* columns than rows, first reduce using the LQ decomposition (if */ /* sufficient workspace available) */ - if (*n >= mnthr) { + if (*n >= mnthr) { - if (wntvn) { + if (wntvn) { /* Path 1t(N much larger than M, JOBVT='N') */ /* No right singular vectors to be computed */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & + i__2, &ierr); /* Zero out above L */ - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + - 1], lda, (ftnlen)1); - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + + 1], lda, (ftnlen)1); + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in A */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - if (wntuo || wntuas) { + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + if (wntuo || wntuas) { /* If left singular vectors desired, generate Q */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], & - work[iwork], &i__2, &ierr, (ftnlen)1); - } - iwork = ie + *m; - nru = 0; - if (wntuo || wntuas) { - nru = *m; - } + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], & + work[iwork], &i__2, &ierr, (ftnlen)1); + } + iwork = ie + *m; + nru = 0; + if (wntuo || wntuas) { + nru = *m; + } /* Perform bidiagonal QR iteration, computing left singular */ /* vectors of A in A if desired */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, & - c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], - info, (ftnlen)1); + dbdsqr_((char *)"U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, & + c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], + info, (ftnlen)1); /* If left singular vectors desired in U, copy them there */ - if (wntuas) { - dlacpy_((char *)"F", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( - ftnlen)1); - } + if (wntuas) { + dlacpy_((char *)"F", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( + ftnlen)1); + } - } else if (wntvo && wntun) { + } else if (wntvo && wntun) { /* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ /* M right singular vectors to be overwritten on A and */ /* no left singular vectors to be computed */ /* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + max(i__2,bdspac)) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; + ir = 1; /* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *m; - if (*lwork >= max(i__2,i__3) + *lda * *m) { + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= max(i__2,i__3) + *lda * *m) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ - ldwrku = *lda; - chunk = *n; - ldwrkr = *lda; - } else /* if(complicated condition) */ { + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *m; - if (*lwork >= max(i__2,i__3) + *m * *m) { + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= max(i__2,i__3) + *m * *m) { /* WORK(IU) is LDA by N and WORK(IR) is M by M */ - ldwrku = *lda; - chunk = *n; - ldwrkr = *m; - } else { + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { /* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ - ldwrku = *m; - chunk = (*lwork - *m * *m - *m) / *m; - ldwrkr = *m; - } - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__2, &ierr); /* Copy L to WORK(IR) and zero out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, - (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + - ldwrkr], &ldwrkr, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, + (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + + ldwrkr], &ldwrkr, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); /* Generate right vectors bidiagonalizing L */ /* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & - work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & + work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of L in WORK(IR) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork] - , info, (ftnlen)1); - iu = ie + *m; + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork] + , info, (ftnlen)1); + iu = ie + *m; /* Multiply right singular vectors of L in WORK(IR) by Q */ /* in A, storing result in WORK(IU) and copying to A */ /* (Workspace: need M*M + 2*M, prefer M*M + M*N + M) */ - i__2 = *n; - i__3 = chunk; - for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__3) { + i__2 = *n; + i__3 = chunk; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__3) { /* Computing MIN */ - i__4 = *n - i__ + 1; - blk = min(i__4,chunk); - dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], & - ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b57, & - work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * - a_dim1 + 1], lda, (ftnlen)1); + i__4 = *n - i__ + 1; + blk = min(i__4,chunk); + dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], & + ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b57, & + work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * + a_dim1 + 1], lda, (ftnlen)1); /* L30: */ - } + } - } else { + } else { /* Insufficient workspace for a fast algorithm */ - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize A */ /* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) */ - i__3 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); /* Generate right vectors bidiagonalizing A */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], & - work[iwork], &i__3, &ierr, (ftnlen)1); - iwork = ie + *m; + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], & + work[iwork], &i__3, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, dum, &c__1, dum, &c__1, &work[ - iwork], info, (ftnlen)1); + dbdsqr_((char *)"L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, dum, &c__1, dum, &c__1, &work[ + iwork], info, (ftnlen)1); - } + } - } else if (wntvo && wntuas) { + } else if (wntvo && wntuas) { /* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */ /* M right singular vectors to be overwritten on A and */ /* M left singular vectors to be computed in U */ /* Computing MAX */ - i__3 = *m << 2; - if (*lwork >= *m * *m + max(i__3,bdspac)) { + i__3 = *m << 2; + if (*lwork >= *m * *m + max(i__3,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; + ir = 1; /* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *m; - if (*lwork >= max(i__3,i__2) + *lda * *m) { + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= max(i__3,i__2) + *lda * *m) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ - ldwrku = *lda; - chunk = *n; - ldwrkr = *lda; - } else /* if(complicated condition) */ { + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *m; - if (*lwork >= max(i__3,i__2) + *m * *m) { + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= max(i__3,i__2) + *m * *m) { /* WORK(IU) is LDA by N and WORK(IR) is M by M */ - ldwrku = *lda; - chunk = *n; - ldwrkr = *m; - } else { + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { /* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ - ldwrku = *m; - chunk = (*lwork - *m * *m - *m) / *m; - ldwrkr = *m; - } - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__3 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__3, &ierr); /* Copy L to U, zeroing about above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( - ftnlen)1); - i__3 = *m - 1; - i__2 = *m - 1; - dlaset_((char *)"U", &i__3, &i__2, &c_b57, &c_b57, &u[(u_dim1 << - 1) + 1], ldu, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( + ftnlen)1); + i__3 = *m - 1; + i__2 = *m - 1; + dlaset_((char *)"U", &i__3, &i__2, &c_b57, &c_b57, &u[(u_dim1 << + 1) + 1], ldu, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__3 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__3, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__3 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in U, copying result to WORK(IR) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__3 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); - dlacpy_((char *)"U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr, - (ftnlen)1); + i__3 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); + dlacpy_((char *)"U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr, + (ftnlen)1); /* Generate right vectors bidiagonalizing L in WORK(IR) */ /* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & - work[iwork], &i__3, &ierr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & + work[iwork], &i__3, &ierr, (ftnlen)1); /* Generate left vectors bidiagonalizing L in U */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) */ - i__3 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__3, &ierr, (ftnlen)1); - iwork = ie + *m; + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__3, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in U, and computing right */ /* singular vectors of L in WORK(IR) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ir], - &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info, (ftnlen)1); - iu = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ir], + &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info, (ftnlen)1); + iu = ie + *m; /* Multiply right singular vectors of L in WORK(IR) by Q */ /* in A, storing result in WORK(IU) and copying to A */ /* (Workspace: need M*M + 2*M, prefer M*M + M*N + M)) */ - i__3 = *n; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += - i__2) { + i__3 = *n; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += + i__2) { /* Computing MIN */ - i__4 = *n - i__ + 1; - blk = min(i__4,chunk); - dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], & - ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b57, & - work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * - a_dim1 + 1], lda, (ftnlen)1); + i__4 = *n - i__ + 1; + blk = min(i__4,chunk); + dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], & + ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b57, & + work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * + a_dim1 + 1], lda, (ftnlen)1); /* L40: */ - } + } - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] - , &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] + , &i__2, &ierr); /* Copy L to U, zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( - ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 << - 1) + 1], ldu, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( + ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 << + 1) + 1], ldu, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in U */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); /* Multiply right vectors bidiagonalizing L by Q in A */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, &work[ - itaup], &a[a_offset], lda, &work[iwork], &i__2, & - ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, &work[ + itaup], &a[a_offset], lda, &work[iwork], &i__2, & + ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1); /* Generate left vectors bidiagonalizing L in U */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntvs) { + } else if (wntvs) { - if (wntun) { + if (wntun) { /* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ /* M right singular vectors to be computed in VT and */ /* no left singular vectors to be computed */ /* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + max(i__2,bdspac)) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; - if (*lwork >= wrkbl + *lda * *m) { + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { /* WORK(IR) is LDA by M */ - ldwrkr = *lda; - } else { + ldwrkr = *lda; + } else { /* WORK(IR) is M by M */ - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy L to WORK(IR), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], & - ldwrkr, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + - ldwrkr], &ldwrkr, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], & + ldwrkr, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + + ldwrkr], &ldwrkr, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Generate right vectors bidiagonalizing L in */ /* WORK(IR) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of L in WORK(IR) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], & - work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], & + work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IR) by */ /* Q in A, storing result in VT */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, - &a[a_offset], lda, &c_b57, &vt[vt_offset], - ldvt, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, + &a[a_offset], lda, &c_b57, &vt[vt_offset], + ldvt, (ftnlen)1, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy result to VT */ - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Zero out above L in A */ - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 - << 1) + 1], lda, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 + << 1) + 1], lda, (ftnlen)1); /* Bidiagonalize L in A */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right vectors bidiagonalizing L by Q in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], & - vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], & + vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntuo) { + } else if (wntuo) { /* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ /* M right singular vectors to be computed in VT and */ /* M left singular vectors to be overwritten on A */ /* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) { + i__2 = *m << 2; + if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *m) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is M by M */ - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } else { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { /* WORK(IU) is M by M and WORK(IR) is M by M */ - ldwrku = *m; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out below it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - ldwrku], &ldwrku, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + ldwrku], &ldwrku, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), copying result to */ /* WORK(IR) */ /* (Workspace: need 2*M*M + 4*M, */ /* prefer 2*M*M+3*M+2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], & - ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], & + ldwrkr, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need 2*M*M + 4*M-1, */ /* prefer 2*M*M+3*M+(M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in WORK(IR) and computing */ /* right singular vectors of L in WORK(IU) */ /* (Workspace: need 2*M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in A, storing result in VT */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, - &a[a_offset], lda, &c_b57, &vt[vt_offset], - ldvt, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, + &a[a_offset], lda, &c_b57, &vt[vt_offset], + ldvt, (ftnlen)1, (ftnlen)1); /* Copy left singular vectors of L to A */ /* (Workspace: need M*M) */ - dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], - lda, (ftnlen)1); + dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], + lda, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Zero out above L in A */ - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 - << 1) + 1], lda, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 + << 1) + 1], lda, (ftnlen)1); /* Bidiagonalize L in A */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right vectors bidiagonalizing L by Q in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); /* Generate left bidiagonalizing vectors of L in A */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, compute left */ /* singular vectors of A in A and compute right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } else if (wntuas) { + } else if (wntuas) { /* Path 6t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='S') */ @@ -3286,524 +3286,524 @@ f"> */ /* M left singular vectors to be computed in U */ /* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + max(i__2,bdspac)) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + *lda * *m) { + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { /* WORK(IU) is LDA by N */ - ldwrku = *lda; - } else { + ldwrku = *lda; + } else { /* WORK(IU) is LDA by M */ - ldwrku = *m; - } - itau = iu + ldwrku * *m; - iwork = itau + *m; + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; /* Compute A=L*Q */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - ldwrku], &ldwrku, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + ldwrku], &ldwrku, (ftnlen)1); /* Generate Q in A */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), copying result to U */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], + ldu, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need M*M + 4*M-1, */ /* prefer M*M+3*M+(M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate left bidiagonalizing vectors in U */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in U and computing right */ /* singular vectors of L in WORK(IU) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in A, storing result in VT */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, - &a[a_offset], lda, &c_b57, &vt[vt_offset], - ldvt, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, + &a[a_offset], lda, &c_b57, &vt[vt_offset], + ldvt, (ftnlen)1, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy L to U, zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 - << 1) + 1], ldu, (ftnlen)1); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 + << 1) + 1], ldu, (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in U */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right bidiagonalizing vectors in U by Q */ /* in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); /* Generate left bidiagonalizing vectors in U */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } + } - } else if (wntva) { + } else if (wntva) { - if (wntun) { + if (wntun) { /* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ /* N right singular vectors to be computed in VT and */ /* no left singular vectors to be computed */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); - if (*lwork >= *m * *m + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); + if (*lwork >= *m * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - ir = 1; - if (*lwork >= wrkbl + *lda * *m) { + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { /* WORK(IR) is LDA by M */ - ldwrkr = *lda; - } else { + ldwrkr = *lda; + } else { /* WORK(IR) is M by M */ - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Copy L to WORK(IR), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], & - ldwrkr, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + - ldwrkr], &ldwrkr, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], & + ldwrkr, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + + ldwrkr], &ldwrkr, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Generate right bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need M*M + 4*M-1, */ /* prefer M*M+3*M+(M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of L in WORK(IR) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], & - work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], & + work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IR) by */ /* Q in VT, storing result in A */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, - &vt[vt_offset], ldvt, &c_b57, &a[a_offset], - lda, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, + &vt[vt_offset], ldvt, &c_b57, &a[a_offset], + lda, (ftnlen)1, (ftnlen)1); /* Copy right singular vectors of A from A to VT */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need M + N, prefer M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Zero out above L in A */ - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 - << 1) + 1], lda, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 + << 1) + 1], lda, (ftnlen)1); /* Bidiagonalize L in A */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right bidiagonalizing vectors in A by Q */ /* in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], & - vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], & + vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & + work[iwork], info, (ftnlen)1); - } + } - } else if (wntuo) { + } else if (wntuo) { /* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ /* N right singular vectors to be computed in VT and */ /* M left singular vectors to be overwritten on A */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); - if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); + if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *m) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is M by M */ - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } else { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { /* WORK(IU) is M by M and WORK(IR) is M by M */ - ldwrku = *m; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - ldwrku], &ldwrku, (ftnlen)1); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + ldwrku], &ldwrku, (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), copying result to */ /* WORK(IR) */ /* (Workspace: need 2*M*M + 4*M, */ /* prefer 2*M*M+3*M+2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], & - ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], & + ldwrkr, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need 2*M*M + 4*M-1, */ /* prefer 2*M*M+3*M+(M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate left bidiagonalizing vectors in WORK(IR) */ /* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] - , &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] + , &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in WORK(IR) and computing */ /* right singular vectors of L in WORK(IU) */ /* (Workspace: need 2*M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in VT, storing result in A */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, - &vt[vt_offset], ldvt, &c_b57, &a[a_offset], - lda, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, + &vt[vt_offset], ldvt, &c_b57, &a[a_offset], + lda, (ftnlen)1, (ftnlen)1); /* Copy right singular vectors of A from A to VT */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Copy left singular vectors of A from WORK(IR) to A */ - dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], - lda, (ftnlen)1); + dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], + lda, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need M + N, prefer M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Zero out above L in A */ - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 - << 1) + 1], lda, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 + << 1) + 1], lda, (ftnlen)1); /* Bidiagonalize L in A */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right bidiagonalizing vectors in A by Q */ /* in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); /* Generate left bidiagonalizing vectors in A */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in A and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } else if (wntuas) { + } else if (wntuas) { /* Path 9t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='A') */ @@ -3811,293 +3811,293 @@ f"> */ /* M left singular vectors to be computed in U */ /* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); - if (*lwork >= *m * *m + max(i__2,bdspac)) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3); + if (*lwork >= *m * *m + max(i__2,bdspac)) { /* Sufficient workspace for a fast algorithm */ - iu = 1; - if (*lwork >= wrkbl + *lda * *m) { + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { /* WORK(IU) is LDA by M */ - ldwrku = *lda; - } else { + ldwrku = *lda; + } else { /* WORK(IU) is M by M */ - ldwrku = *m; - } - itau = iu + ldwrku * *m; - iwork = itau + *m; + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + - ldwrku], &ldwrku, (ftnlen)1); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + + ldwrku], &ldwrku, (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), copying result to U */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], - ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], + ldu, (ftnlen)1); /* Generate right bidiagonalizing vectors in WORK(IU) */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] - , &work[iwork], &i__2, &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup] + , &work[iwork], &i__2, &ierr, (ftnlen)1); /* Generate left bidiagonalizing vectors in U */ /* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in U and computing right */ /* singular vectors of L in WORK(IU) */ /* (Workspace: need M*M + BDSPAC) */ - dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in VT, storing result in A */ /* (Workspace: need M*M) */ - dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, - &vt[vt_offset], ldvt, &c_b57, &a[a_offset], - lda, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, + &vt[vt_offset], ldvt, &c_b57, &a[a_offset], + lda, (ftnlen)1, (ftnlen)1); /* Copy right singular vectors of A from A to VT */ - dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); - } else { + } else { /* Insufficient workspace for a fast algorithm */ - itau = 1; - iwork = itau + *m; + itau = 1; + iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (Workspace: need 2*M, prefer M + M*NB) */ - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt, (ftnlen)1); /* Generate Q in VT */ /* (Workspace: need M + N, prefer M + N*NB) */ - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); /* Copy L to U, zeroing out above it */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], - ldu, (ftnlen)1); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 - << 1) + 1], ldu, (ftnlen)1); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], + ldu, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 + << 1) + 1], ldu, (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize L in U */ /* (Workspace: need 4*M, prefer 3*M + 2*M*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); /* Multiply right bidiagonalizing vectors in U by Q */ /* in VT */ /* (Workspace: need 3*M + N, prefer 3*M + N*NB) */ - i__2 = *lwork - iwork + 1; - dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); /* Generate left bidiagonalizing vectors in U */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr, (ftnlen)1); - iwork = ie + *m; + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr, (ftnlen)1); + iwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and computing right */ /* singular vectors of A in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info, (ftnlen)1); + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info, (ftnlen)1); - } + } - } + } - } + } - } else { + } else { /* N .LT. MNTHR */ /* Path 10t(N greater than M, but not much larger) */ /* Reduce to bidiagonal form without LQ decomposition */ - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; /* Bidiagonalize A */ /* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) */ - i__2 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__2, &ierr); - if (wntuas) { + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__2, &ierr); + if (wntuas) { /* If left singular vectors desired in U, copy result to U */ /* and generate left bidiagonalizing vectors in U */ /* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) */ - dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( - ftnlen)1); - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[ - iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntvas) { + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, ( + ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[ + iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntvas) { /* If right singular vectors desired in VT, copy result to */ /* VT and generate right bidiagonalizing vectors in VT */ /* (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB) */ - dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, ( - ftnlen)1); - if (wntva) { - nrvt = *n; - } - if (wntvs) { - nrvt = *m; - } - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntuo) { + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, ( + ftnlen)1); + if (wntva) { + nrvt = *n; + } + if (wntvs) { + nrvt = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntuo) { /* If left singular vectors desired in A, generate left */ /* bidiagonalizing vectors in A */ /* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[ - iwork], &i__2, &ierr, (ftnlen)1); - } - if (wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[ + iwork], &i__2, &ierr, (ftnlen)1); + } + if (wntvo) { /* If right singular vectors desired in A, generate right */ /* bidiagonalizing vectors in A */ /* (Workspace: need 4*M, prefer 3*M + M*NB) */ - i__2 = *lwork - iwork + 1; - dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__2, &ierr, (ftnlen)1); - } - iwork = ie + *m; - if (wntuas || wntuo) { - nru = *m; - } - if (wntun) { - nru = 0; - } - if (wntvas || wntvo) { - ncvt = *n; - } - if (wntvn) { - ncvt = 0; - } - if (! wntuo && ! wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__2, &ierr, (ftnlen)1); + } + iwork = ie + *m; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (! wntuo && ! wntvo) { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in U and computing right singular */ /* vectors in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info, (ftnlen)1); - } else if (! wntuo && wntvo) { + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info, (ftnlen)1); + } else if (! wntuo && wntvo) { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in U and computing right singular */ /* vectors in A */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info, (ftnlen)1); - } else { + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info, (ftnlen)1); + } else { /* Perform bidiagonal QR iteration, if desired, computing */ /* left singular vectors in A and computing right singular */ /* vectors in VT */ /* (Workspace: need BDSPAC) */ - dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info, (ftnlen)1); - } + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info, (ftnlen)1); + } - } + } } @@ -4105,42 +4105,42 @@ f"> */ /* to WORK( 2:MINMN ) */ if (*info != 0) { - if (ie > 2) { - i__2 = minmn - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__ + 1] = work[i__ + ie - 1]; + if (ie > 2) { + i__2 = minmn - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + 1] = work[i__ + ie - 1]; /* L50: */ - } - } - if (ie < 2) { - for (i__ = minmn - 1; i__ >= 1; --i__) { - work[i__ + 1] = work[i__ + ie - 1]; + } + } + if (ie < 2) { + for (i__ = minmn - 1; i__ >= 1; --i__) { + work[i__ + 1] = work[i__ + ie - 1]; /* L60: */ - } - } + } + } } /* Undo scaling if necessary */ if (iscl == 1) { - if (anrm > bignum) { - dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr, (ftnlen)1); - } - if (*info != 0 && anrm > bignum) { - i__2 = minmn - 1; - dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2], - &minmn, &ierr, (ftnlen)1); - } - if (anrm < smlnum) { - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr, (ftnlen)1); - } - if (*info != 0 && anrm < smlnum) { - i__2 = minmn - 1; - dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2], - &minmn, &ierr, (ftnlen)1); - } + if (anrm > bignum) { + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr, (ftnlen)1); + } + if (*info != 0 && anrm > bignum) { + i__2 = minmn - 1; + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2], + &minmn, &ierr, (ftnlen)1); + } + if (anrm < smlnum) { + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr, (ftnlen)1); + } + if (*info != 0 && anrm < smlnum) { + i__2 = minmn - 1; + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2], + &minmn, &ierr, (ftnlen)1); + } } /* Return optimal workspace in WORK(1) */ @@ -4154,5 +4154,5 @@ f"> */ } /* dgesvd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgetf2.cpp b/lib/linalg/dgetf2.cpp index 0cb6b57a2f..c5951c8703 100644 --- a/lib/linalg/dgetf2.cpp +++ b/lib/linalg/dgetf2.cpp @@ -1,13 +1,13 @@ /* fortran/dgetf2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -131,7 +131,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) + lda, integer *ipiv, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -139,13 +139,13 @@ f"> */ /* Local variables */ integer i__, j, jp; - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *), dscal_(integer *, doublereal *, doublereal *, integer - *); + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), dscal_(integer *, doublereal *, doublereal *, integer + *); doublereal sfmin; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); extern doublereal dlamch_(char *, ftnlen); extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -185,22 +185,22 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGETF2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGETF2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* Compute machine safe minimum */ @@ -212,47 +212,47 @@ f"> */ /* Find pivot and test for singularity. */ - i__2 = *m - j + 1; - jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); - ipiv[j] = jp; - if (a[jp + j * a_dim1] != 0.) { + i__2 = *m - j + 1; + jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); + ipiv[j] = jp; + if (a[jp + j * a_dim1] != 0.) { /* Apply the interchange to columns 1:N. */ - if (jp != j) { - dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); - } + if (jp != j) { + dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); + } /* Compute elements J+1:M of J-th column. */ - if (j < *m) { - if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { - i__2 = *m - j; - d__1 = 1. / a[j + j * a_dim1]; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } else { - i__2 = *m - j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; + if (j < *m) { + if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { + i__2 = *m - j; + d__1 = 1. / a[j + j * a_dim1]; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } else { + i__2 = *m - j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; /* L20: */ - } - } - } + } + } + } - } else if (*info == 0) { + } else if (*info == 0) { - *info = j; - } + *info = j; + } - if (j < min(*m,*n)) { + if (j < min(*m,*n)) { /* Update trailing submatrix. */ - i__2 = *m - j; - i__3 = *n - j; - dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + ( - j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda); - } + i__2 = *m - j; + i__3 = *n - j; + dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + ( + j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda); + } /* L10: */ } return 0; @@ -262,5 +262,5 @@ f"> */ } /* dgetf2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgetrf.cpp b/lib/linalg/dgetrf.cpp index eca7500a03..cd1e8b50fe 100644 --- a/lib/linalg/dgetrf.cpp +++ b/lib/linalg/dgetrf.cpp @@ -1,13 +1,13 @@ /* fortran/dgetrf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -132,26 +132,26 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) + lda, integer *ipiv, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; /* Local variables */ integer i__, j, jb, nb; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer iinfo; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( - char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, - integer *, integer *, integer *, integer *), dgetrf2_(integer *, - integer *, doublereal *, integer *, integer *, integer *); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( + char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *), dgetrf2_(integer *, + integer *, doublereal *, integer *, integer *, integer *); /* -- LAPACK computational routine -- */ @@ -188,99 +188,99 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGETRF", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGETRF", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); + 1); if (nb <= 1 || nb >= min(*m,*n)) { /* Use unblocked code. */ - dgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info); + dgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info); } else { /* Use blocked code. */ - i__1 = min(*m,*n); - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + i__1 = min(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Computing MIN */ - i__3 = min(*m,*n) - j + 1; - jb = min(i__3,nb); + i__3 = min(*m,*n) - j + 1; + jb = min(i__3,nb); /* Factor diagonal and subdiagonal blocks and test for exact */ /* singularity. */ - i__3 = *m - j + 1; - dgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); + i__3 = *m - j + 1; + dgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); /* Adjust INFO and the pivot indices. */ - if (*info == 0 && iinfo > 0) { - *info = iinfo + j - 1; - } + if (*info == 0 && iinfo > 0) { + *info = iinfo + j - 1; + } /* Computing MIN */ - i__4 = *m, i__5 = j + jb - 1; - i__3 = min(i__4,i__5); - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = j - 1 + ipiv[i__]; + i__4 = *m, i__5 = j + jb - 1; + i__3 = min(i__4,i__5); + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = j - 1 + ipiv[i__]; /* L10: */ - } + } /* Apply interchanges to columns 1:J-1. */ - i__3 = j - 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); + i__3 = j - 1; + i__4 = j + jb - 1; + dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); - if (j + jb <= *n) { + if (j + jb <= *n) { /* Apply interchanges to columns J+JB:N. */ - i__3 = *n - j - jb + 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & - ipiv[1], &c__1); + i__3 = *n - j - jb + 1; + i__4 = j + jb - 1; + dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & + ipiv[1], &c__1); /* Compute block row of U. */ - i__3 = *n - j - jb + 1; - dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, & - c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * - a_dim1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, ( - ftnlen)4); - if (j + jb <= *m) { + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, & + c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * + a_dim1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, ( + ftnlen)4); + if (j + jb <= *m) { /* Update trailing submatrix. */ - i__3 = *m - j - jb + 1; - i__4 = *n - j - jb + 1; - dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, - &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + - jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) * - a_dim1], lda, (ftnlen)12, (ftnlen)12); - } - } + i__3 = *m - j - jb + 1; + i__4 = *n - j - jb + 1; + dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, + &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) * + a_dim1], lda, (ftnlen)12, (ftnlen)12); + } + } /* L20: */ - } + } } return 0; @@ -289,5 +289,5 @@ f"> */ } /* dgetrf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgetrf2.cpp b/lib/linalg/dgetrf2.cpp index 94162fdca8..c7097bbfed 100644 --- a/lib/linalg/dgetrf2.cpp +++ b/lib/linalg/dgetrf2.cpp @@ -1,13 +1,13 @@ /* static/dgetrf2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -133,7 +133,7 @@ static doublereal c_b16 = -1.; /* ===================================================================== */ /* Subroutine */ int dgetrf2_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) + lda, integer *ipiv, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -142,20 +142,20 @@ static doublereal c_b16 = -1.; /* Local variables */ integer i__, n1, n2; doublereal temp; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dgemm_(char *, char *, integer *, integer *, integer * - , doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer iinfo; doublereal sfmin; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); extern doublereal dlamch_(char *, ftnlen); extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlaswp_( - integer *, doublereal *, integer *, integer *, integer *, integer - *, integer *); + integer *, doublereal *, integer *, integer *, integer *, integer + *, integer *); /* -- LAPACK computational routine -- */ @@ -192,32 +192,32 @@ static doublereal c_b16 = -1.; /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*m)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGETRF2", &i__1, (ftnlen)7); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGETRF2", &i__1, (ftnlen)7); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } if (*m == 1) { /* Use unblocked code for one row case */ /* Just need to handle IPIV and INFO */ - ipiv[1] = 1; - if (a[a_dim1 + 1] == 0.) { - *info = 1; - } + ipiv[1] = 1; + if (a[a_dim1 + 1] == 0.) { + *info = 1; + } } else if (*n == 1) { @@ -226,98 +226,98 @@ static doublereal c_b16 = -1.; /* Compute machine safe minimum */ - sfmin = dlamch_((char *)"S", (ftnlen)1); + sfmin = dlamch_((char *)"S", (ftnlen)1); /* Find pivot and test for singularity */ - i__ = idamax_(m, &a[a_dim1 + 1], &c__1); - ipiv[1] = i__; - if (a[i__ + a_dim1] != 0.) { + i__ = idamax_(m, &a[a_dim1 + 1], &c__1); + ipiv[1] = i__; + if (a[i__ + a_dim1] != 0.) { /* Apply the interchange */ - if (i__ != 1) { - temp = a[a_dim1 + 1]; - a[a_dim1 + 1] = a[i__ + a_dim1]; - a[i__ + a_dim1] = temp; - } + if (i__ != 1) { + temp = a[a_dim1 + 1]; + a[a_dim1 + 1] = a[i__ + a_dim1]; + a[i__ + a_dim1] = temp; + } /* Compute elements 2:M of the column */ - if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) { - i__1 = *m - 1; - d__1 = 1. / a[a_dim1 + 1]; - dscal_(&i__1, &d__1, &a[a_dim1 + 2], &c__1); - } else { - i__1 = *m - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - a[i__ + 1 + a_dim1] /= a[a_dim1 + 1]; + if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) { + i__1 = *m - 1; + d__1 = 1. / a[a_dim1 + 1]; + dscal_(&i__1, &d__1, &a[a_dim1 + 2], &c__1); + } else { + i__1 = *m - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + 1 + a_dim1] /= a[a_dim1 + 1]; /* L10: */ - } - } + } + } - } else { - *info = 1; - } + } else { + *info = 1; + } } else { /* Use recursive code */ - n1 = min(*m,*n) / 2; - n2 = *n - n1; + n1 = min(*m,*n) / 2; + n2 = *n - n1; /* [ A11 ] */ /* Factor [ --- ] */ /* [ A21 ] */ - dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo); - if (*info == 0 && iinfo > 0) { - *info = iinfo; - } + dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo); + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } /* [ A12 ] */ /* Apply interchanges to [ --- ] */ /* [ A22 ] */ - dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], & - c__1); + dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], & + c__1); /* Solve A12 */ - dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b13, &a[a_offset], lda, &a[( - n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); + dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b13, &a[a_offset], lda, &a[( + n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); /* Update A22 */ - i__1 = *m - n1; - dgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &c_b16, &a[n1 + 1 + a_dim1], lda, & - a[(n1 + 1) * a_dim1 + 1], lda, &c_b13, &a[n1 + 1 + (n1 + 1) * - a_dim1], lda, (ftnlen)1, (ftnlen)1); + i__1 = *m - n1; + dgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &c_b16, &a[n1 + 1 + a_dim1], lda, & + a[(n1 + 1) * a_dim1 + 1], lda, &c_b13, &a[n1 + 1 + (n1 + 1) * + a_dim1], lda, (ftnlen)1, (ftnlen)1); /* Factor A22 */ - i__1 = *m - n1; - dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 + - 1], &iinfo); + i__1 = *m - n1; + dgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 + + 1], &iinfo); /* Adjust INFO and the pivot indices */ - if (*info == 0 && iinfo > 0) { - *info = iinfo + n1; - } - i__1 = min(*m,*n); - for (i__ = n1 + 1; i__ <= i__1; ++i__) { - ipiv[i__] += n1; + if (*info == 0 && iinfo > 0) { + *info = iinfo + n1; + } + i__1 = min(*m,*n); + for (i__ = n1 + 1; i__ <= i__1; ++i__) { + ipiv[i__] += n1; /* L20: */ - } + } /* Apply interchanges to A21 */ - i__1 = n1 + 1; - i__2 = min(*m,*n); - dlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1); + i__1 = n1 + 1; + i__2 = min(*m,*n); + dlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1); } return 0; @@ -327,5 +327,5 @@ static doublereal c_b16 = -1.; } /* dgetrf2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgetri.cpp b/lib/linalg/dgetri.cpp index 23178071b6..368c6701ac 100644 --- a/lib/linalg/dgetri.cpp +++ b/lib/linalg/dgetri.cpp @@ -1,13 +1,13 @@ /* fortran/dgetri.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -138,31 +138,31 @@ f"> */ /* > \ingroup doubleGEcomputational */ /* ===================================================================== */ -/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer - *ipiv, doublereal *work, integer *lwork, integer *info) +/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer + *ipiv, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, j, jb, nb, jj, jp, nn, iws; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), - dgemv_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), + dgemv_(char *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, ftnlen); integer nbmin; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *), dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( - char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( + char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork; - extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal - *, integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal + *, integer *, integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; @@ -202,55 +202,55 @@ f"> */ /* Function Body */ *info = 0; nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); + ftnlen)1); lwkopt = *n * nb; work[1] = (doublereal) lwkopt; lquery = *lwork == -1; if (*n < 0) { - *info = -1; + *info = -1; } else if (*lda < max(1,*n)) { - *info = -3; + *info = -3; } else if (*lwork < max(1,*n) && ! lquery) { - *info = -6; + *info = -6; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGETRI", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGETRI", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */ /* and the inverse is not computed. */ dtrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, ( - ftnlen)8); + ftnlen)8); if (*info > 0) { - return 0; + return 0; } nbmin = 2; ldwork = *n; if (nb > 1 && nb < *n) { /* Computing MAX */ - i__1 = ldwork * nb; - iws = max(i__1,1); - if (*lwork < iws) { - nb = *lwork / ldwork; + i__1 = ldwork * nb; + iws = max(i__1,1); + if (*lwork < iws) { + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } } else { - iws = *n; + iws = *n; } /* Solve the equation inv(A)*L = inv(U) for inv(A). */ @@ -259,75 +259,75 @@ f"> */ /* Use unblocked code. */ - for (j = *n; j >= 1; --j) { + for (j = *n; j >= 1; --j) { /* Copy current column of L to WORK and replace with zeros. */ - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - work[i__] = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + work[i__] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = 0.; /* L10: */ - } + } /* Compute current column of inv(A). */ - if (j < *n) { - i__1 = *n - j; - dgemv_((char *)"No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 - + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 - + 1], &c__1, (ftnlen)12); - } + if (j < *n) { + i__1 = *n - j; + dgemv_((char *)"No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 + + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 + + 1], &c__1, (ftnlen)12); + } /* L20: */ - } + } } else { /* Use blocked code. */ - nn = (*n - 1) / nb * nb + 1; - i__1 = -nb; - for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { + nn = (*n - 1) / nb * nb + 1; + i__1 = -nb; + for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { /* Computing MIN */ - i__2 = nb, i__3 = *n - j + 1; - jb = min(i__2,i__3); + i__2 = nb, i__3 = *n - j + 1; + jb = min(i__2,i__3); /* Copy current block column of L to WORK and replace with */ /* zeros. */ - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = *n; - for (i__ = jj + 1; i__ <= i__3; ++i__) { - work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; - a[i__ + jj * a_dim1] = 0.; + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = *n; + for (i__ = jj + 1; i__ <= i__3; ++i__) { + work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; + a[i__ + jj * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ - } + } /* Compute current block column of inv(A). */ - if (j + jb <= *n) { - i__2 = *n - j - jb + 1; - dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20, - &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], & - ldwork, &c_b22, &a[j * a_dim1 + 1], lda, (ftnlen)12, ( - ftnlen)12); - } - dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b22, & - work[j], &ldwork, &a[j * a_dim1 + 1], lda, (ftnlen)5, ( - ftnlen)5, (ftnlen)12, (ftnlen)4); + if (j + jb <= *n) { + i__2 = *n - j - jb + 1; + dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20, + &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], & + ldwork, &c_b22, &a[j * a_dim1 + 1], lda, (ftnlen)12, ( + ftnlen)12); + } + dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b22, & + work[j], &ldwork, &a[j * a_dim1 + 1], lda, (ftnlen)5, ( + ftnlen)5, (ftnlen)12, (ftnlen)4); /* L50: */ - } + } } /* Apply column interchanges. */ for (j = *n - 1; j >= 1; --j) { - jp = ipiv[j]; - if (jp != j) { - dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); - } + jp = ipiv[j]; + if (jp != j) { + dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); + } /* L60: */ } @@ -339,5 +339,5 @@ f"> */ } /* dgetri_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dgetrs.cpp b/lib/linalg/dgetrs.cpp index 4df18e8650..ca10730a0b 100644 --- a/lib/linalg/dgetrs.cpp +++ b/lib/linalg/dgetrs.cpp @@ -1,13 +1,13 @@ /* fortran/dgetrs.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -143,20 +143,20 @@ f"> */ /* > \ingroup doubleGEcomputational */ /* ===================================================================== */ -/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * - ldb, integer *info, ftnlen trans_len) +/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, integer *info, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; /* Local variables */ extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( - char *, integer *, ftnlen), dlaswp_(integer *, doublereal *, - integer *, integer *, integer *, integer *, integer *); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( + char *, integer *, ftnlen), dlaswp_(integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *); logical notran; @@ -198,27 +198,27 @@ f"> */ *info = 0; notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_( - trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -1; + trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*nrhs < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,*n)) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DGETRS", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DGETRS", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { - return 0; + return 0; } if (notran) { @@ -227,38 +227,38 @@ f"> */ /* Apply row interchanges to the right hand sides. */ - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); /* Solve L*X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)4); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)12, (ftnlen)4); /* Solve U*X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b12, & - a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b12, & + a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)12, (ftnlen)8); } else { /* Solve A**T * X = B. */ /* Solve U**T *X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)9, (ftnlen)8); /* Solve L**T *X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)4); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)9, (ftnlen)4); /* Apply row interchanges to the solution vectors. */ - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); } return 0; @@ -268,5 +268,5 @@ f"> */ } /* dgetrs_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlabad.cpp b/lib/linalg/dlabad.cpp index 96eb6efcca..a753834632 100644 --- a/lib/linalg/dlabad.cpp +++ b/lib/linalg/dlabad.cpp @@ -1,13 +1,13 @@ /* fortran/dlabad.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -113,8 +113,8 @@ f"> */ /* SMALL and LARGE to avoid overflow and underflow problems. */ if (d_lg10(large) > 2e3) { - *small = sqrt(*small); - *large = sqrt(*large); + *small = sqrt(*small); + *large = sqrt(*large); } return 0; @@ -124,5 +124,5 @@ f"> */ } /* dlabad_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlabrd.cpp b/lib/linalg/dlabrd.cpp index 5775cc7bc1..a7f9113e5c 100644 --- a/lib/linalg/dlabrd.cpp +++ b/lib/linalg/dlabrd.cpp @@ -1,13 +1,13 @@ /* fortran/dlabrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -233,21 +233,21 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal * - a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, - doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer - *ldy) + a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, + doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer + *ldy) { /* System generated locals */ - integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, - i__3; + integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, + i__3; /* Local variables */ integer i__; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dgemv_(char *, integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -290,236 +290,236 @@ f"> */ /* Function Body */ if (*m <= 0 || *n <= 0) { - return 0; + return 0; } if (*m >= *n) { /* Reduce to upper bidiagonal form */ - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i:m,i) */ - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, - &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & - c__1, (ftnlen)12); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, - &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * - a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, + &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & + c__1, (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, + &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * + a_dim1], &c__1, (ftnlen)12); /* Generate reflection Q(i) to annihilate A(i+1:m,i) */ - i__2 = *m - i__ + 1; + i__2 = *m - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * - a_dim1], &c__1, &tauq[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * + a_dim1], &c__1, &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; /* Compute Y(i+1:n,i) */ - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * - a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & - y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], - lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * - y_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ - i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], - ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * - y_dim1 + 1], &c__1, (ftnlen)9); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * - a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, - &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & + y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], + lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], + ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1, (ftnlen)9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, + &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); /* Update A(i,i+1:n) */ - i__2 = *n - i__; - dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( - i__ + 1) * a_dim1], lda, (ftnlen)12); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * - a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ - i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9); + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( + i__ + 1) * a_dim1], lda, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ + i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9); /* Generate reflection P(i) to annihilate A(i,i+2:n) */ - i__2 = *n - i__; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( - i__3,*n) * a_dim1], lda, &taup[i__]); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - a[i__ + (i__ + 1) * a_dim1] = 1.; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min( + i__3,*n) * a_dim1], lda, &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; /* Compute X(i+1:m,i) */ - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ - + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], - lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, ( - ftnlen)12); - i__2 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], - ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ - i__ * x_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *m - i__; - dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + - a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)12); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); - } + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], + lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, ( + ftnlen)12); + i__2 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], + ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ + i__ * x_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *m - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + } /* L10: */ - } + } } else { /* Reduce to lower bidiagonal form */ - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i,i:n) */ - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, - &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], - lda, (ftnlen)12); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], - lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], - lda, (ftnlen)9); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, + &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], + lda, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], + lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], + lda, (ftnlen)9); /* Generate reflection P(i) to annihilate A(i,i+1:n) */ - i__2 = *n - i__ + 1; + i__2 = *n - i__ + 1; /* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * - a_dim1], lda, &taup[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * + a_dim1], lda, &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; /* Compute X(i+1:m,i) */ - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * - a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & - x[i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], - ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * - x_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + - a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + - 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * - x_dim1 + 1], &c__1, (ftnlen)12); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * + a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & + x[i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], + ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1, (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); /* Update A(i+1:m,i) */ - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + - a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + - 1 + i__ * a_dim1], &c__1, (ftnlen)12); - i__2 = *m - i__; - dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ - i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + + 1 + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ + i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12); /* Generate reflection Q(i) to annihilate A(i+2:m,i) */ - i__2 = *m - i__; + i__2 = *m - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + - i__ * a_dim1], &c__1, &tauq[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*m) + + i__ * a_dim1], &c__1, &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; /* Compute Y(i+1:n,i) */ - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + - 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, - &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ - i__ * y_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ - i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); - i__2 = *m - i__; - dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], - ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ - i__ * y_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *n - i__; - dgemv_((char *)"Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 - + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ - + 1 + i__ * y_dim1], &c__1, (ftnlen)9); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); - } + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, + &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)9); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], + ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *n - i__; + dgemv_((char *)"Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 + + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + + 1 + i__ * y_dim1], &c__1, (ftnlen)9); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } /* L20: */ - } + } } return 0; @@ -528,5 +528,5 @@ f"> */ } /* dlabrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlacn2.cpp b/lib/linalg/dlacn2.cpp index befb0b4e52..7293447d88 100644 --- a/lib/linalg/dlacn2.cpp +++ b/lib/linalg/dlacn2.cpp @@ -1,13 +1,13 @@ /* fortran/dlacn2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -157,8 +157,8 @@ f"> */ /* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x, - integer *isgn, doublereal *est, integer *kase, integer *isave) +/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x, + integer *isgn, doublereal *est, integer *kase, integer *isave) { /* System generated locals */ integer i__1; @@ -172,8 +172,8 @@ f"> */ doublereal xs, temp; extern doublereal dasum_(integer *, doublereal *, integer *); integer jlast; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); extern integer idamax_(integer *, doublereal *, integer *); doublereal altsgn, estold; @@ -209,22 +209,22 @@ f"> */ /* Function Body */ if (*kase == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 1. / (doublereal) (*n); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1. / (doublereal) (*n); /* L10: */ - } - *kase = 1; - isave[1] = 1; - return 0; + } + *kase = 1; + isave[1] = 1; + return 0; } switch (isave[1]) { - case 1: goto L20; - case 2: goto L40; - case 3: goto L70; - case 4: goto L110; - case 5: goto L140; + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L110; + case 5: goto L140; } /* ................ ENTRY (ISAVE( 1 ) = 1) */ @@ -232,21 +232,21 @@ f"> */ L20: if (*n == 1) { - v[1] = x[1]; - *est = abs(v[1]); + v[1] = x[1]; + *est = abs(v[1]); /* ... QUIT */ - goto L150; + goto L150; } *est = dasum_(n, &x[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - if (x[i__] >= 0.) { - x[i__] = 1.; - } else { - x[i__] = -1.; - } - isgn[i__] = i_dnnt(&x[i__]); + if (x[i__] >= 0.) { + x[i__] = 1.; + } else { + x[i__] = -1.; + } + isgn[i__] = i_dnnt(&x[i__]); /* L30: */ } *kase = 2; @@ -265,7 +265,7 @@ L40: L50: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 0.; + x[i__] = 0.; /* L60: */ } x[isave[2]] = 1.; @@ -282,14 +282,14 @@ L70: *est = dasum_(n, &v[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - if (x[i__] >= 0.) { - xs = 1.; - } else { - xs = -1.; - } - if (i_dnnt(&xs) != isgn[i__]) { - goto L90; - } + if (x[i__] >= 0.) { + xs = 1.; + } else { + xs = -1.; + } + if (i_dnnt(&xs) != isgn[i__]) { + goto L90; + } /* L80: */ } /* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ @@ -298,17 +298,17 @@ L70: L90: /* TEST FOR CYCLING. */ if (*est <= estold) { - goto L120; + goto L120; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - if (x[i__] >= 0.) { - x[i__] = 1.; - } else { - x[i__] = -1.; - } - isgn[i__] = i_dnnt(&x[i__]); + if (x[i__] >= 0.) { + x[i__] = 1.; + } else { + x[i__] = -1.; + } + isgn[i__] = i_dnnt(&x[i__]); /* L100: */ } *kase = 2; @@ -322,8 +322,8 @@ L110: jlast = isave[2]; isave[2] = idamax_(n, &x[1], &c__1); if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { - ++isave[3]; - goto L50; + ++isave[3]; + goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ @@ -332,9 +332,9 @@ L120: altsgn = 1.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + - 1.); - altsgn = -altsgn; + x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + + 1.); + altsgn = -altsgn; /* L130: */ } *kase = 1; @@ -347,8 +347,8 @@ L120: L140: temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; if (temp > *est) { - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - *est = temp; + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; } L150: @@ -360,5 +360,5 @@ L150: } /* dlacn2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlacpy.cpp b/lib/linalg/dlacpy.cpp index b1e62a5336..813a669202 100644 --- a/lib/linalg/dlacpy.cpp +++ b/lib/linalg/dlacpy.cpp @@ -1,13 +1,13 @@ /* fortran/dlacpy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -120,7 +120,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *b, integer *ldb, ftnlen uplo_len) + a, integer *lda, doublereal *b, integer *ldb, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; @@ -159,35 +159,35 @@ f"> */ /* Function Body */ if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; /* L10: */ - } + } /* L20: */ - } + } } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; /* L30: */ - } + } /* L40: */ - } + } } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; /* L50: */ - } + } /* L60: */ - } + } } return 0; @@ -196,5 +196,5 @@ f"> */ } /* dlacpy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dladiv.cpp b/lib/linalg/dladiv.cpp index 7ffd5485cc..d12fb854f0 100644 --- a/lib/linalg/dladiv.cpp +++ b/lib/linalg/dladiv.cpp @@ -1,13 +1,13 @@ /* fortran/dladiv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -107,8 +107,8 @@ f"> */ /* > \ingroup doubleOTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *p, doublereal *q) +/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *d__, doublereal *p, doublereal *q) { /* System generated locals */ doublereal d__1, d__2; @@ -116,8 +116,8 @@ f"> */ /* Local variables */ doublereal s, aa, ab, bb, cc, cd, dd, be, un, ov, eps; extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -157,30 +157,30 @@ f"> */ eps = dlamch_((char *)"Epsilon", (ftnlen)7); be = 2. / (eps * eps); if (ab >= ov * .5) { - aa *= .5; - bb *= .5; - s *= 2.; + aa *= .5; + bb *= .5; + s *= 2.; } if (cd >= ov * .5) { - cc *= .5; - dd *= .5; - s *= .5; + cc *= .5; + dd *= .5; + s *= .5; } if (ab <= un * 2. / eps) { - aa *= be; - bb *= be; - s /= be; + aa *= be; + bb *= be; + s /= be; } if (cd <= un * 2. / eps) { - cc *= be; - dd *= be; - s *= be; + cc *= be; + dd *= be; + s *= be; } if (abs(*d__) <= abs(*c__)) { - dladiv1_(&aa, &bb, &cc, &dd, p, q); + dladiv1_(&aa, &bb, &cc, &dd, p, q); } else { - dladiv1_(&bb, &aa, &dd, &cc, p, q); - *q = -(*q); + dladiv1_(&bb, &aa, &dd, &cc, p, q); + *q = -(*q); } *p *= s; *q *= s; @@ -192,12 +192,12 @@ f"> */ } /* dladiv_ */ /* > \ingroup doubleOTHERauxiliary */ -/* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *p, doublereal *q) +/* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *d__, doublereal *p, doublereal *q) { doublereal r__, t; - extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -230,8 +230,8 @@ f"> */ } /* dladiv1_ */ /* > \ingroup doubleOTHERauxiliary */ -doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal - *d__, doublereal *r__, doublereal *t) +doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal + *d__, doublereal *r__, doublereal *t) { /* System generated locals */ doublereal ret_val; @@ -256,14 +256,14 @@ doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal /* .. Executable Statements .. */ if (*r__ != 0.) { - br = *b * *r__; - if (br != 0.) { - ret_val = (*a + br) * *t; - } else { - ret_val = *a * *t + *b * *t * *r__; - } + br = *b * *r__; + if (br != 0.) { + ret_val = (*a + br) * *t; + } else { + ret_val = *a * *t + *b * *t * *r__; + } } else { - ret_val = (*a + *d__ * (*b / *c__)) * *t; + ret_val = (*a + *d__ * (*b / *c__)) * *t; } return ret_val; @@ -273,5 +273,5 @@ doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal } /* dladiv2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlae2.cpp b/lib/linalg/dlae2.cpp index 2a1be2816d..7351921b21 100644 --- a/lib/linalg/dlae2.cpp +++ b/lib/linalg/dlae2.cpp @@ -1,13 +1,13 @@ /* fortran/dlae2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -118,8 +118,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2) +/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *rt1, doublereal *rt2) { /* System generated locals */ doublereal d__1; @@ -156,48 +156,48 @@ extern "C" { tb = *b + *b; ab = abs(tb); if (abs(*a) > abs(*c__)) { - acmx = *a; - acmn = *c__; + acmx = *a; + acmn = *c__; } else { - acmx = *c__; - acmn = *a; + acmx = *c__; + acmn = *a; } if (adf > ab) { /* Computing 2nd power */ - d__1 = ab / adf; - rt = adf * sqrt(d__1 * d__1 + 1.); + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); } else if (adf < ab) { /* Computing 2nd power */ - d__1 = adf / ab; - rt = ab * sqrt(d__1 * d__1 + 1.); + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); } else { /* Includes case AB=ADF=0 */ - rt = ab * sqrt(2.); + rt = ab * sqrt(2.); } if (sm < 0.) { - *rt1 = (sm - rt) * .5; + *rt1 = (sm - rt) * .5; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.) { - *rt1 = (sm + rt) * .5; + *rt1 = (sm + rt) * .5; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { /* Includes case RT1 = RT2 = 0 */ - *rt1 = rt * .5; - *rt2 = rt * -.5; + *rt1 = rt * .5; + *rt2 = rt * -.5; } return 0; @@ -206,5 +206,5 @@ extern "C" { } /* dlae2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed0.cpp b/lib/linalg/dlaed0.cpp index 41b13a3cac..68fee93814 100644 --- a/lib/linalg/dlaed0.cpp +++ b/lib/linalg/dlaed0.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed0.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -24,7 +24,7 @@ static doublereal c_b23 = 1.; static doublereal c_b24 = 0.; static integer c__1 = 1; -/* > \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced +/* > \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. */ /* =========== DOCUMENTATION =========== */ @@ -197,10 +197,10 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, - doublereal *d__, doublereal *e, doublereal *q, integer *ldq, - doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, - integer *info) +/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, + doublereal *d__, doublereal *e, doublereal *q, integer *ldq, + doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, + integer *info) { /* System generated locals */ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; @@ -214,33 +214,33 @@ f"> */ integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; doublereal temp; integer curr; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer iperm; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer indxq, iwrem; extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *, integer *); + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); integer iqptr; - extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *, - integer *, integer *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *, integer *, integer *, doublereal - *, doublereal *, integer *, integer *); + extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *); integer tlvls; - extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen); integer igivcl; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer igivnm, submat, curprb, subpbs, igivpt; - extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - ftnlen); + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + ftnlen); integer curlvl, matsiz, iprmpt, smlsiz; @@ -285,30 +285,30 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 2) { - *info = -1; + *info = -1; } else if (*icompq == 1 && *qsiz < max(0,*n)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*ldq < max(1,*n)) { - *info = -7; + *info = -7; } else if (*ldqs < max(1,*n)) { - *info = -9; + *info = -9; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED0", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED0", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( - ftnlen)6, (ftnlen)1); + ftnlen)6, (ftnlen)1); /* Determine the size and placement of the submatrices, and save in */ /* the leading elements of IWORK. */ @@ -318,18 +318,18 @@ f"> */ tlvls = 0; L10: if (iwork[subpbs] > smlsiz) { - for (j = subpbs; j >= 1; --j) { - iwork[j * 2] = (iwork[j] + 1) / 2; - iwork[(j << 1) - 1] = iwork[j] / 2; + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; /* L20: */ - } - ++tlvls; - subpbs <<= 1; - goto L10; + } + ++tlvls; + subpbs <<= 1; + goto L10; } i__1 = subpbs; for (j = 2; j <= i__1; ++j) { - iwork[j] += iwork[j - 1]; + iwork[j] += iwork[j - 1]; /* L30: */ } @@ -339,10 +339,10 @@ L10: spm1 = subpbs - 1; i__1 = spm1; for (i__ = 1; i__ <= i__1; ++i__) { - submat = iwork[i__] + 1; - smm1 = submat - 1; - d__[smm1] -= (d__1 = e[smm1], abs(d__1)); - d__[submat] -= (d__1 = e[smm1], abs(d__1)); + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); /* L40: */ } @@ -352,35 +352,35 @@ L10: /* Set up workspaces for eigenvalues only/accumulate new vectors */ /* routine */ - temp = log((doublereal) (*n)) / log(2.); - lgn = (integer) temp; - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - iprmpt = indxq + *n + 1; - iperm = iprmpt + *n * lgn; - iqptr = iperm + *n * lgn; - igivpt = iqptr + *n + 2; - igivcl = igivpt + *n * lgn; + temp = log((doublereal) (*n)) / log(2.); + lgn = (integer) temp; + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; - igivnm = 1; - iq = igivnm + (*n << 1) * lgn; + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; /* Computing 2nd power */ - i__1 = *n; - iwrem = iq + i__1 * i__1 + 1; + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; /* Initialize pointers */ - i__1 = subpbs; - for (i__ = 0; i__ <= i__1; ++i__) { - iwork[iprmpt + i__] = 1; - iwork[igivpt + i__] = 1; + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; /* L50: */ - } - iwork[iqptr] = 1; + } + iwork[iqptr] = 1; } /* Solve each submatrix eigenproblem at the bottom of the divide and */ @@ -389,43 +389,43 @@ L10: curr = 0; i__1 = spm1; for (i__ = 0; i__ <= i__1; ++i__) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[1]; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 1] - iwork[i__]; - } - if (*icompq == 2) { - dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat + - submat * q_dim1], ldq, &work[1], info, (ftnlen)1); - if (*info != 0) { - goto L130; - } - } else { - dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + - iwork[iqptr + curr]], &matsiz, &work[1], info, (ftnlen)1); - if (*info != 0) { - goto L130; - } - if (*icompq == 1) { - dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * - q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], - &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], - ldqs, (ftnlen)1, (ftnlen)1); - } + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + if (*icompq == 2) { + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat + + submat * q_dim1], ldq, &work[1], info, (ftnlen)1); + if (*info != 0) { + goto L130; + } + } else { + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + + iwork[iqptr + curr]], &matsiz, &work[1], info, (ftnlen)1); + if (*info != 0) { + goto L130; + } + if (*icompq == 1) { + dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * + q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], + &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], + ldqs, (ftnlen)1, (ftnlen)1); + } /* Computing 2nd power */ - i__2 = matsiz; - iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; - ++curr; - } - k = 1; - i__2 = iwork[i__ + 1]; - for (j = submat; j <= i__2; ++j) { - iwork[indxq + j] = k; - ++k; + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; /* L60: */ - } + } /* L70: */ } @@ -437,20 +437,20 @@ L10: curlvl = 1; L80: if (subpbs > 1) { - spm2 = subpbs - 2; - i__1 = spm2; - for (i__ = 0; i__ <= i__1; i__ += 2) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[2]; - msd2 = iwork[1]; - curprb = 0; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 2] - iwork[i__]; - msd2 = matsiz / 2; - ++curprb; - } + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } /* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ /* into an eigensystem of size MATSIZ. */ @@ -460,27 +460,27 @@ L80: /* and eigenvectors of a full symmetric matrix (which was reduced to */ /* tridiagonal form) are desired. */ - if (*icompq == 2) { - dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], - ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & - msd2, &work[1], &iwork[subpbs + 1], info); - } else { - dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ - submat], &qstore[submat * qstore_dim1 + 1], ldqs, & - iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & - work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] - , &iwork[igivpt], &iwork[igivcl], &work[igivnm], & - work[iwrem], &iwork[subpbs + 1], info); - } - if (*info != 0) { - goto L130; - } - iwork[i__ / 2 + 1] = iwork[i__ + 2]; + if (*icompq == 2) { + dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], + ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & + msd2, &work[1], &iwork[subpbs + 1], info); + } else { + dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ + submat], &qstore[submat * qstore_dim1 + 1], ldqs, & + iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & + work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] + , &iwork[igivpt], &iwork[igivcl], &work[igivnm], & + work[iwrem], &iwork[subpbs + 1], info); + } + if (*info != 0) { + goto L130; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; /* L90: */ - } - subpbs /= 2; - ++curlvl; - goto L80; + } + subpbs /= 2; + ++curlvl; + goto L80; } /* end while */ @@ -489,33 +489,33 @@ L80: /* merge step. */ if (*icompq == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; - dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 - + 1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + + 1], &c__1); /* L100: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); } else if (*icompq == 2) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; - dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); /* L110: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); - dlacpy_((char *)"A", n, n, &work[*n + 1], n, &q[q_offset], ldq, (ftnlen)1); + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + dlacpy_((char *)"A", n, n, &work[*n + 1], n, &q[q_offset], ldq, (ftnlen)1); } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; /* L120: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); } goto L140; @@ -530,5 +530,5 @@ L140: } /* dlaed0_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed1.cpp b/lib/linalg/dlaed1.cpp index a448e3363e..ff6c537c7c 100644 --- a/lib/linalg/dlaed1.cpp +++ b/lib/linalg/dlaed1.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed1.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -184,29 +184,29 @@ f"> */ /* > Modified by Francoise Tisseur, University of Tennessee */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, - integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, - doublereal *work, integer *iwork, integer *info) +/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, + integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, + doublereal *work, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; /* Local variables */ integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer indxp; - extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, integer *, integer *, integer *), dlaed3_(integer *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - doublereal *, doublereal *, integer *); + extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *, integer *), dlaed3_(integer *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, integer *); integer idlmda; - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen); integer coltyp; @@ -244,26 +244,26 @@ f"> */ *info = 0; if (*n < 0) { - *info = -1; + *info = -1; } else if (*ldq < max(1,*n)) { - *info = -4; + *info = -4; } else /* if(complicated condition) */ { /* Computing MIN */ - i__1 = 1, i__2 = *n / 2; - if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { - *info = -7; - } + i__1 = 1, i__2 = *n / 2; + if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { + *info = -7; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED1", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED1", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* The following values are integer pointers which indicate */ @@ -292,36 +292,36 @@ f"> */ /* Deflate eigenvalues. */ dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ - iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ - indxc], &iwork[indxp], &iwork[coltyp], info); + iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ + indxc], &iwork[indxp], &iwork[coltyp], info); if (*info != 0) { - goto L20; + goto L20; } /* Solve Secular Equation. */ if (k != 0) { - is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + - 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; - dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], - &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ - is], info); - if (*info != 0) { - goto L20; - } + is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; + dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], + &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ + is], info); + if (*info != 0) { + goto L20; + } /* Prepare the INDXQ sorting permutation. */ - n1 = k; - n2 = *n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indxq[i__] = i__; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; /* L10: */ - } + } } L20: @@ -332,5 +332,5 @@ L20: } /* dlaed1_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed2.cpp b/lib/linalg/dlaed2.cpp index 746c07ba33..c56d856171 100644 --- a/lib/linalg/dlaed2.cpp +++ b/lib/linalg/dlaed2.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -234,10 +234,10 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal * - d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, - doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, - integer *indx, integer *indxc, integer *indxp, integer *coltyp, - integer *info) + d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, + doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, + integer *indx, integer *indxc, integer *indxp, integer *coltyp, + integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; @@ -253,19 +253,19 @@ f"> */ integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; doublereal eps, tau, tol; integer psm[4], imax, jmax; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); integer ctot[4]; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dcopy_(integer *, doublereal *, integer *, doublereal - *, integer *); - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), dlacpy_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -314,33 +314,33 @@ f"> */ *info = 0; if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldq < max(1,*n)) { - *info = -6; + *info = -6; } else /* if(complicated condition) */ { /* Computing MIN */ - i__1 = 1, i__2 = *n / 2; - if (min(i__1,i__2) > *n1 || *n / 2 < *n1) { - *info = -3; - } + i__1 = 1, i__2 = *n / 2; + if (min(i__1,i__2) > *n1 || *n / 2 < *n1) { + *info = -3; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } n2 = *n - *n1; n1p1 = *n1 + 1; if (*rho < 0.) { - dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); } /* Normalize z so that norm(z) = 1. Since z is the concatenation of */ @@ -357,7 +357,7 @@ f"> */ i__1 = *n; for (i__ = n1p1; i__ <= i__1; ++i__) { - indxq[i__] += *n1; + indxq[i__] += *n1; /* L10: */ } @@ -365,13 +365,13 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = d__[indxq[i__]]; + dlamda[i__] = d__[indxq[i__]]; /* L20: */ } dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - indx[i__] = indxq[indxc[i__]]; + indx[i__] = indxq[indxc[i__]]; /* L30: */ } @@ -382,7 +382,7 @@ f"> */ eps = dlamch_((char *)"Epsilon", (ftnlen)7); /* Computing MAX */ d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)) - ; + ; tol = eps * 8. * max(d__3,d__4); /* If the rank-1 modifier is small enough, no more needs to be done */ @@ -390,19 +390,19 @@ f"> */ /* elements in D. */ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { - *k = 0; - iq2 = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__ = indx[j]; - dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); - dlamda[j] = d__[i__]; - iq2 += *n; + *k = 0; + iq2 = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = indx[j]; + dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + dlamda[j] = d__[i__]; + iq2 += *n; /* L40: */ - } - dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1); - dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); - goto L190; + } + dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1); + dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); + goto L190; } /* If there are multiple eigenvalues then the problem deflates. Here */ @@ -413,12 +413,12 @@ f"> */ i__1 = *n1; for (i__ = 1; i__ <= i__1; ++i__) { - coltyp[i__] = 1; + coltyp[i__] = 1; /* L50: */ } i__1 = *n; for (i__ = n1p1; i__ <= i__1; ++i__) { - coltyp[i__] = 3; + coltyp[i__] = 3; /* L60: */ } @@ -427,96 +427,96 @@ f"> */ k2 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { - nj = indx[j]; - if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { + nj = indx[j]; + if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - coltyp[nj] = 4; - indxp[k2] = nj; - if (j == *n) { - goto L100; - } - } else { - pj = nj; - goto L80; - } + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + if (j == *n) { + goto L100; + } + } else { + pj = nj; + goto L80; + } /* L70: */ } L80: ++j; nj = indx[j]; if (j > *n) { - goto L100; + goto L100; } if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - coltyp[nj] = 4; - indxp[k2] = nj; + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; } else { /* Check if eigenvalues are close enough to allow deflation. */ - s = z__[pj]; - c__ = z__[nj]; + s = z__[pj]; + c__ = z__[nj]; /* Find sqrt(a**2+b**2) without overflow or */ /* destructive underflow. */ - tau = dlapy2_(&c__, &s); - t = d__[nj] - d__[pj]; - c__ /= tau; - s = -s / tau; - if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + tau = dlapy2_(&c__, &s); + t = d__[nj] - d__[pj]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { /* Deflation is possible. */ - z__[nj] = tau; - z__[pj] = 0.; - if (coltyp[nj] != coltyp[pj]) { - coltyp[nj] = 2; - } - coltyp[pj] = 4; - drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & - c__, &s); + z__[nj] = tau; + z__[pj] = 0.; + if (coltyp[nj] != coltyp[pj]) { + coltyp[nj] = 2; + } + coltyp[pj] = 4; + drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & + c__, &s); /* Computing 2nd power */ - d__1 = c__; + d__1 = c__; /* Computing 2nd power */ - d__2 = s; - t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); + d__2 = s; + t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); /* Computing 2nd power */ - d__1 = s; + d__1 = s; /* Computing 2nd power */ - d__2 = c__; - d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); - d__[pj] = t; - --k2; - i__ = 1; + d__2 = c__; + d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); + d__[pj] = t; + --k2; + i__ = 1; L90: - if (k2 + i__ <= *n) { - if (d__[pj] < d__[indxp[k2 + i__]]) { - indxp[k2 + i__ - 1] = indxp[k2 + i__]; - indxp[k2 + i__] = pj; - ++i__; - goto L90; - } else { - indxp[k2 + i__ - 1] = pj; - } - } else { - indxp[k2 + i__ - 1] = pj; - } - pj = nj; - } else { - ++(*k); - dlamda[*k] = d__[pj]; - w[*k] = z__[pj]; - indxp[*k] = pj; - pj = nj; - } + if (k2 + i__ <= *n) { + if (d__[pj] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = pj; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = pj; + } + } else { + indxp[k2 + i__ - 1] = pj; + } + pj = nj; + } else { + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + pj = nj; + } } goto L80; L100: @@ -534,13 +534,13 @@ L100: /* empty). */ for (j = 1; j <= 4; ++j) { - ctot[j - 1] = 0; + ctot[j - 1] = 0; /* L110: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { - ct = coltyp[j]; - ++ctot[ct - 1]; + ct = coltyp[j]; + ++ctot[ct - 1]; /* L120: */ } @@ -558,11 +558,11 @@ L100: i__1 = *n; for (j = 1; j <= i__1; ++j) { - js = indxp[j]; - ct = coltyp[js]; - indx[psm[ct - 1]] = js; - indxc[psm[ct - 1]] = j; - ++psm[ct - 1]; + js = indxp[j]; + ct = coltyp[js]; + indx[psm[ct - 1]] = js; + indxc[psm[ct - 1]] = j; + ++psm[ct - 1]; /* L130: */ } @@ -576,44 +576,44 @@ L100: iq2 = (ctot[0] + ctot[1]) * *n1 + 1; i__1 = ctot[0]; for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); - z__[i__] = d__[js]; - ++i__; - iq1 += *n1; + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; /* L140: */ } i__1 = ctot[1]; for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); - dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); - z__[i__] = d__[js]; - ++i__; - iq1 += *n1; - iq2 += n2; + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; + iq2 += n2; /* L150: */ } i__1 = ctot[2]; for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); - z__[i__] = d__[js]; - ++i__; - iq2 += n2; + js = indx[i__]; + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq2 += n2; /* L160: */ } iq1 = iq2; i__1 = ctot[3]; for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); - iq2 += *n; - z__[i__] = d__[js]; - ++i__; + js = indx[i__]; + dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + iq2 += *n; + z__[i__] = d__[js]; + ++i__; /* L170: */ } @@ -621,16 +621,16 @@ L100: /* into the last N - K slots of D and Q respectively. */ if (*k < *n) { - dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq, - (ftnlen)1); - i__1 = *n - *k; - dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); + dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq, + (ftnlen)1); + i__1 = *n - *k; + dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); } /* Copy CTOT into COLTYP for referencing in DLAED3. */ for (j = 1; j <= 4; ++j) { - coltyp[j] = ctot[j - 1]; + coltyp[j] = ctot[j - 1]; /* L180: */ } @@ -642,5 +642,5 @@ L190: } /* dlaed2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed3.cpp b/lib/linalg/dlaed3.cpp index e56c3fb41b..c1f5e908dc 100644 --- a/lib/linalg/dlaed3.cpp +++ b/lib/linalg/dlaed3.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed3.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -208,9 +208,9 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal * - d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, - doublereal *q2, integer *indx, integer *ctot, doublereal *w, - doublereal *s, integer *info) + d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, + doublereal *q2, integer *indx, integer *ctot, doublereal *w, + doublereal *s, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; @@ -223,18 +223,18 @@ f"> */ integer i__, j, n2, n12, ii, n23, iq2; doublereal temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), - dcopy_(integer *, doublereal *, integer *, doublereal *, integer - *), dlaed4_(integer *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer + *), dlaed4_(integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *); extern doublereal dlamc3_(doublereal *, doublereal *); - extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen), - dlaset_(char *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -278,22 +278,22 @@ f"> */ *info = 0; if (*k < 0) { - *info = -1; + *info = -1; } else if (*n < *k) { - *info = -2; + *info = -2; } else if (*ldq < max(1,*n)) { - *info = -6; + *info = -6; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED3", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED3", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*k == 0) { - return 0; + return 0; } /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ @@ -315,38 +315,38 @@ f"> */ i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; /* L10: */ } i__1 = *k; for (j = 1; j <= i__1; ++j) { - dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], - info); + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); /* If the zero finder fails, the computation is terminated. */ - if (*info != 0) { - goto L120; - } + if (*info != 0) { + goto L120; + } /* L20: */ } if (*k == 1) { - goto L110; + goto L110; } if (*k == 2) { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - w[1] = q[j * q_dim1 + 1]; - w[2] = q[j * q_dim1 + 2]; - ii = indx[1]; - q[j * q_dim1 + 1] = w[ii]; - ii = indx[2]; - q[j * q_dim1 + 2] = w[ii]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + w[1] = q[j * q_dim1 + 1]; + w[2] = q[j * q_dim1 + 2]; + ii = indx[1]; + q[j * q_dim1 + 1] = w[ii]; + ii = indx[2]; + q[j * q_dim1 + 2] = w[ii]; /* L30: */ - } - goto L110; + } + goto L110; } /* Compute updated W. */ @@ -359,22 +359,22 @@ f"> */ dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); i__1 = *k; for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); /* L40: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); /* L50: */ - } + } /* L60: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = sqrt(-w[i__]); - w[i__] = d_sign(&d__1, &s[i__]); + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__1, &s[i__]); /* L70: */ } @@ -382,18 +382,18 @@ f"> */ i__1 = *k; for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - s[i__] = w[i__] / q[i__ + j * q_dim1]; + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__] = w[i__] / q[i__ + j * q_dim1]; /* L80: */ - } - temp = dnrm2_(k, &s[1], &c__1); - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - ii = indx[i__]; - q[i__ + j * q_dim1] = s[ii] / temp; + } + temp = dnrm2_(k, &s[1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + ii = indx[i__]; + q[i__ + j * q_dim1] = s[ii] / temp; /* L90: */ - } + } /* L100: */ } @@ -406,22 +406,22 @@ L110: n23 = ctot[2] + ctot[3]; dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen) - 1); + 1); iq2 = *n1 * n12 + 1; if (n23 != 0) { - dgemm_((char *)"N", (char *)"N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & - c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & + c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1, (ftnlen)1); } else { - dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, ( - ftnlen)1); + dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, ( + ftnlen)1); } dlacpy_((char *)"A", &n12, k, &q[q_offset], ldq, &s[1], &n12, (ftnlen)1); if (n12 != 0) { - dgemm_((char *)"N", (char *)"N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, - &q[q_offset], ldq, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, + &q[q_offset], ldq, (ftnlen)1, (ftnlen)1); } else { - dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1); + dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1); } @@ -433,5 +433,5 @@ L120: } /* dlaed3_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed4.cpp b/lib/linalg/dlaed4.cpp index 5cc622887d..ca532571dd 100644 --- a/lib/linalg/dlaed4.cpp +++ b/lib/linalg/dlaed4.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed4.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -161,9 +161,9 @@ f"> */ /* > at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, - integer *info) +/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__, + doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, + integer *info) { /* System generated locals */ integer i__1; @@ -187,9 +187,9 @@ f"> */ integer niter; logical swtch; extern /* Subroutine */ int dlaed5_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *), dlaed6_(integer *, - logical *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *); + doublereal *, doublereal *, doublereal *), dlaed6_(integer *, + logical *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); logical swtch3; extern doublereal dlamch_(char *, ftnlen); logical orgati; @@ -237,13 +237,13 @@ f"> */ /* Presumably, I=1 upon entry */ - *dlam = d__[1] + *rho * z__[1] * z__[1]; - delta[1] = 1.; - return 0; + *dlam = d__[1] + *rho * z__[1] * z__[1]; + delta[1] = 1.; + return 0; } if (*n == 2) { - dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); - return 0; + dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); + return 0; } /* Compute machine epsilon */ @@ -257,140 +257,140 @@ f"> */ /* Initialize some basic variables */ - ii = *n - 1; - niter = 1; + ii = *n - 1; + niter = 1; /* Calculate initial guess */ - midpt = *rho / 2.; + midpt = *rho / 2.; /* If ||Z||_2 is not one, then TEMP should be set to */ /* RHO * ||Z||_2^2 / TWO */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - midpt; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; /* L10: */ - } + } - psi = 0.; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / delta[j]; + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; /* L20: */ - } + } - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[* - n]; + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[* + n]; - if (w <= 0.) { - temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) - + z__[*n] * z__[*n] / *rho; - if (c__ <= temp) { - tau = *rho; - } else { - del = d__[*n] - d__[*n - 1]; - a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n] - ; - b = z__[*n] * z__[*n] * del; - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - } + if (w <= 0.) { + temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) + + z__[*n] * z__[*n] / *rho; + if (c__ <= temp) { + tau = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n] + ; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + } /* It can be proved that */ /* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */ - dltlb = midpt; - dltub = *rho; - } else { - del = d__[*n] - d__[*n - 1]; - a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * del; - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } + dltlb = midpt; + dltub = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } /* It can be proved that */ /* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ - dltlb = 0.; - dltub = midpt; - } + dltlb = 0.; + dltub = midpt; + } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; /* L30: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L40: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* Test for convergence */ - if (abs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } - if (w <= 0.) { - dltlb = max(dltlb,tau); - } else { - dltub = min(dltub,tau); - } + if (w <= 0.) { + dltlb = max(dltlb,tau); + } else { + dltub = min(dltub,tau); + } /* Calculate the new step */ - ++niter; - c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; - a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * ( - dpsi + dphi); - b = delta[*n - 1] * delta[*n] * w; - if (c__ < 0.) { - c__ = abs(c__); - } - if (c__ == 0.) { + ++niter; + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * ( + dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { /* ETA = B/A */ /* ETA = RHO - TAU */ /* ETA = DLTUB - TAU */ /* Update proposed by Li, Ren-Cang: */ - eta = -w / (dpsi + dphi); - } else if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } + eta = -w / (dpsi + dphi); + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -398,82 +398,82 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; /* L50: */ - } + } - tau += eta; + tau += eta; /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L60: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* Main loop to update the values of the array DELTA */ - iter = niter + 1; + iter = niter + 1; - for (niter = iter; niter <= 30; ++niter) { + for (niter = iter; niter <= 30; ++niter) { /* Test for convergence */ - if (abs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } - if (w <= 0.) { - dltlb = max(dltlb,tau); - } else { - dltub = min(dltub,tau); - } + if (w <= 0.) { + dltlb = max(dltlb,tau); + } else { + dltub = min(dltub,tau); + } /* Calculate the new step */ - c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; - a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * - (dpsi + dphi); - b = delta[*n - 1] * delta[*n] * w; - if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * + (dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -481,57 +481,57 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; /* L70: */ - } + } - tau += eta; + tau += eta; /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L80: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( - dpsi + dphi); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* L90: */ - } + } /* Return with INFO = 1, NITER = MAXIT and not converged */ - *info = 1; - *dlam = d__[*i__] + tau; - goto L250; + *info = 1; + *dlam = d__[*i__] + tau; + goto L250; /* End for the case I = N */ @@ -539,228 +539,228 @@ f"> */ /* The case for I < N */ - niter = 1; - ip1 = *i__ + 1; + niter = 1; + ip1 = *i__ + 1; /* Calculate initial guess */ - del = d__[ip1] - d__[*i__]; - midpt = del / 2.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - midpt; + del = d__[ip1] - d__[*i__]; + midpt = del / 2.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; /* L100: */ - } + } - psi = 0.; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / delta[j]; + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; /* L110: */ - } + } - phi = 0.; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / delta[j]; + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / delta[j]; /* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / - delta[ip1]; + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / + delta[ip1]; - if (w > 0.) { + if (w > 0.) { /* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */ /* We choose d(i) as origin. */ - orgati = TRUE_; - a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * del; - if (a > 0.) { - tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } else { - tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } - dltlb = 0.; - dltub = midpt; - } else { + orgati = TRUE_; + a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * del; + if (a > 0.) { + tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } + dltlb = 0.; + dltub = midpt; + } else { /* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */ /* We choose d(i+1) as origin. */ - orgati = FALSE_; - a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * del; - if (a < 0.) { - tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( - d__1)))); - } else { - tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / - (c__ * 2.); - } - dltlb = -midpt; - dltub = 0.; - } + orgati = FALSE_; + a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * del; + if (a < 0.) { + tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + dltlb = -midpt; + dltub = 0.; + } - if (orgati) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - tau; + if (orgati) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; /* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[ip1] - tau; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[ip1] - tau; /* L140: */ - } - } - if (orgati) { - ii = *i__; - } else { - ii = *i__ + 1; - } - iim1 = ii - 1; - iip1 = ii + 1; + } + } + if (orgati) { + ii = *i__; + } else { + ii = *i__ + 1; + } + iim1 = ii - 1; + iip1 = ii + 1; /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L150: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L160: */ - } + } - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* W is the value of the secular function with */ /* its ii-th element removed. */ - swtch3 = FALSE_; - if (orgati) { - if (w < 0.) { - swtch3 = TRUE_; - } - } else { - if (w > 0.) { - swtch3 = TRUE_; - } - } - if (ii == 1 || ii == *n) { - swtch3 = FALSE_; - } + swtch3 = FALSE_; + if (orgati) { + if (w < 0.) { + swtch3 = TRUE_; + } + } else { + if (w > 0.) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w += temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + - abs(tau) * dw; + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; /* Test for convergence */ - if (abs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } - if (w <= 0.) { - dltlb = max(dltlb,tau); - } else { - dltub = min(dltub,tau); - } + if (w <= 0.) { + dltlb = max(dltlb,tau); + } else { + dltub = min(dltub,tau); + } /* Calculate the new step */ - ++niter; - if (! swtch3) { - if (orgati) { + ++niter; + if (! swtch3) { + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * - d__1); - } else { + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * + d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * - d__1); - } - a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * - dw; - b = delta[*i__] * delta[ip1] * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * - (dpsi + dphi); - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - } else { + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * + d__1); + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * + dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * + (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + } else { /* Interpolation using THREE most relevant poles */ - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / delta[iim1]; - temp1 *= temp1; - c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[ - iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); - } else { - temp1 = z__[iip1] / delta[iip1]; - temp1 *= temp1; - c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[ - iim1]) * temp1; - zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); - if (*info != 0) { - goto L250; - } - } + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[ + iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[ + iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); + if (*info != 0) { + goto L250; + } + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -768,181 +768,181 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta >= 0.) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } - prew = w; + prew = w; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; /* L180: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L190: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L200: */ - } + } - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + ( - d__1 = tau + eta, abs(d__1)) * dw; + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + ( + d__1 = tau + eta, abs(d__1)) * dw; - swtch = FALSE_; - if (orgati) { - if (-w > abs(prew) / 10.) { - swtch = TRUE_; - } - } else { - if (w > abs(prew) / 10.) { - swtch = TRUE_; - } - } + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.) { + swtch = TRUE_; + } + } - tau += eta; + tau += eta; /* Main loop to update the values of the array DELTA */ - iter = niter + 1; + iter = niter + 1; - for (niter = iter; niter <= 30; ++niter) { + for (niter = iter; niter <= 30; ++niter) { /* Test for convergence */ - if (abs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } - if (w <= 0.) { - dltlb = max(dltlb,tau); - } else { - dltub = min(dltub,tau); - } + if (w <= 0.) { + dltlb = max(dltlb,tau); + } else { + dltub = min(dltub,tau); + } /* Calculate the new step */ - if (! swtch3) { - if (! swtch) { - if (orgati) { + if (! swtch3) { + if (! swtch) { + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( - d__1 * d__1); - } else { + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( + d__1 * d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * - (d__1 * d__1); - } - } else { - temp = z__[ii] / delta[ii]; - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; - } - a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] - * dw; - b = delta[*i__] * delta[ip1] * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + delta[ip1] * - delta[ip1] * (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + delta[*i__] * delta[ - *i__] * (dpsi + dphi); - } - } else { - a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] - * delta[ip1] * dphi; - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) - / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } else { + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * + (d__1 * d__1); + } + } else { + temp = z__[ii] / delta[ii]; + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] + * dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * + delta[ip1] * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[ + *i__] * (dpsi + dphi); + } + } else { + a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] + * delta[ip1] * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } else { /* Interpolation using THREE most relevant poles */ - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; - zz[0] = delta[iim1] * delta[iim1] * dpsi; - zz[2] = delta[iip1] * delta[iip1] * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / delta[iim1]; - temp1 *= temp1; - c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - - d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + - dphi); - } else { - temp1 = z__[iip1] / delta[iip1]; - temp1 *= temp1; - c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - - d__[iim1]) * temp1; - zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - - temp1)); - zz[2] = z__[iip1] * z__[iip1]; - } - } - dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, - info); - if (*info != 0) { - goto L250; - } - } + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; + zz[0] = delta[iim1] * delta[iim1] * dpsi; + zz[2] = delta[iip1] * delta[iip1] * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] + - d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] + - d__[iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - + temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + } + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, + info); + if (*info != 0) { + goto L250; + } + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -950,76 +950,76 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta >= 0.) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; /* L210: */ - } + } - tau += eta; - prew = w; + tau += eta; + prew = w; /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L220: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L230: */ - } + } - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. - + abs(tau) * dw; - if (w * prew > 0. && abs(w) > abs(prew) / 10.) { - swtch = ! swtch; - } + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = ! swtch; + } /* L240: */ - } + } /* Return with INFO = 1, NITER = MAXIT and not converged */ - *info = 1; - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } + *info = 1; + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } } @@ -1032,5 +1032,5 @@ L250: } /* dlaed4_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed5.cpp b/lib/linalg/dlaed5.cpp index 14e8a429ee..558676d269 100644 --- a/lib/linalg/dlaed5.cpp +++ b/lib/linalg/dlaed5.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed5.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -124,8 +124,8 @@ f"> */ /* > at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dlam) +/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, + doublereal *delta, doublereal *rho, doublereal *dlam) { /* System generated locals */ doublereal d__1; @@ -164,49 +164,49 @@ f"> */ /* Function Body */ del = d__[2] - d__[1]; if (*i__ == 1) { - w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; - if (w > 0.) { - b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[1] * z__[1] * del; + w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; + if (w > 0.) { + b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * del; /* B > ZERO, always */ - tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); - *dlam = d__[1] + tau; - delta[1] = -z__[1] / tau; - delta[2] = z__[2] / (del - tau); - } else { - b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * del; - if (b > 0.) { - tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); - } else { - tau = (b - sqrt(b * b + c__ * 4.)) / 2.; - } - *dlam = d__[2] + tau; - delta[1] = -z__[1] / (del + tau); - delta[2] = -z__[2] / tau; - } - temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); - delta[1] /= temp; - delta[2] /= temp; + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + *dlam = d__[1] + tau; + delta[1] = -z__[1] / tau; + delta[2] = z__[2] / (del - tau); + } else { + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + } + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; } else { /* Now I=2 */ - b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * del; - if (b > 0.) { - tau = (b + sqrt(b * b + c__ * 4.)) / 2.; - } else { - tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); - } - *dlam = d__[2] + tau; - delta[1] = -z__[1] / (del + tau); - delta[2] = -z__[2] / tau; - temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); - delta[1] /= temp; - delta[2] /= temp; + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; } return 0; @@ -215,5 +215,5 @@ f"> */ } /* dlaed5_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed6.cpp b/lib/linalg/dlaed6.cpp index 7a855780f0..aae975971f 100644 --- a/lib/linalg/dlaed6.cpp +++ b/lib/linalg/dlaed6.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed6.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -157,8 +157,8 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal * - rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal * - tau, integer *info) + rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal * + tau, integer *info) { /* System generated locals */ integer i__1; @@ -211,65 +211,65 @@ f"> */ *info = 0; if (*orgati) { - lbd = d__[2]; - ubd = d__[3]; + lbd = d__[2]; + ubd = d__[3]; } else { - lbd = d__[1]; - ubd = d__[2]; + lbd = d__[1]; + ubd = d__[2]; } if (*finit < 0.) { - lbd = 0.; + lbd = 0.; } else { - ubd = 0.; + ubd = 0.; } niter = 1; *tau = 0.; if (*kniter == 2) { - if (*orgati) { - temp = (d__[3] - d__[2]) / 2.; - c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); - a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; - b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; - } else { - temp = (d__[1] - d__[2]) / 2.; - c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); - a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; - b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; - } + if (*orgati) { + temp = (d__[3] - d__[2]) / 2.; + c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); + a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; + b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; + } else { + temp = (d__[1] - d__[2]) / 2.; + c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); + a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; + b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; + } /* Computing MAX */ - d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); - temp = max(d__1,d__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.) { - *tau = b / a; - } else if (a <= 0.) { - *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) - )); - } - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.; - } - if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { - *tau = 0.; - } else { - temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau - * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( - d__[3] * (d__[3] - *tau)); - if (temp <= 0.) { - lbd = *tau; - } else { - ubd = *tau; - } - if (abs(*finit) <= abs(temp)) { - *tau = 0.; - } - } + d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); + temp = max(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + *tau = b / a; + } else if (a <= 0.) { + *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) + )); + } + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { + *tau = 0.; + } else { + temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau + * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( + d__[3] * (d__[3] - *tau)); + if (temp <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + if (abs(*finit) <= abs(temp)) { + *tau = 0.; + } + } } /* get machine parameters for possible scaling to avoid overflow */ @@ -291,75 +291,75 @@ f"> */ if (*orgati) { /* Computing MIN */ - d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * - tau, abs(d__2)); - temp = min(d__3,d__4); + d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * + tau, abs(d__2)); + temp = min(d__3,d__4); } else { /* Computing MIN */ - d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * - tau, abs(d__2)); - temp = min(d__3,d__4); + d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * + tau, abs(d__2)); + temp = min(d__3,d__4); } scale = FALSE_; if (temp <= small1) { - scale = TRUE_; - if (temp <= small2) { + scale = TRUE_; + if (temp <= small2) { /* Scale up by power of radix nearest 1/SAFMIN**(2/3) */ - sclfac = sminv2; - sclinv = small2; - } else { + sclfac = sminv2; + sclinv = small2; + } else { /* Scale up by power of radix nearest 1/SAFMIN**(1/3) */ - sclfac = sminv1; - sclinv = small1; - } + sclfac = sminv1; + sclinv = small1; + } /* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */ - for (i__ = 1; i__ <= 3; ++i__) { - dscale[i__ - 1] = d__[i__] * sclfac; - zscale[i__ - 1] = z__[i__] * sclfac; + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__] * sclfac; + zscale[i__ - 1] = z__[i__] * sclfac; /* L10: */ - } - *tau *= sclfac; - lbd *= sclfac; - ubd *= sclfac; + } + *tau *= sclfac; + lbd *= sclfac; + ubd *= sclfac; } else { /* Copy D and Z to DSCALE and ZSCALE */ - for (i__ = 1; i__ <= 3; ++i__) { - dscale[i__ - 1] = d__[i__]; - zscale[i__ - 1] = z__[i__]; + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__]; + zscale[i__ - 1] = z__[i__]; /* L20: */ - } + } } fc = 0.; df = 0.; ddf = 0.; for (i__ = 1; i__ <= 3; ++i__) { - temp = 1. / (dscale[i__ - 1] - *tau); - temp1 = zscale[i__ - 1] * temp; - temp2 = temp1 * temp; - temp3 = temp2 * temp; - fc += temp1 / dscale[i__ - 1]; - df += temp2; - ddf += temp3; + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + fc += temp1 / dscale[i__ - 1]; + df += temp2; + ddf += temp3; /* L30: */ } f = *finit + *tau * fc; if (abs(f) <= 0.) { - goto L60; + goto L60; } if (f <= 0.) { - lbd = *tau; + lbd = *tau; } else { - ubd = *tau; + ubd = *tau; } /* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */ @@ -377,71 +377,71 @@ f"> */ for (niter = iter; niter <= 40; ++niter) { - if (*orgati) { - temp1 = dscale[1] - *tau; - temp2 = dscale[2] - *tau; - } else { - temp1 = dscale[0] - *tau; - temp2 = dscale[1] - *tau; - } - a = (temp1 + temp2) * f - temp1 * temp2 * df; - b = temp1 * temp2 * f; - c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; + if (*orgati) { + temp1 = dscale[1] - *tau; + temp2 = dscale[2] - *tau; + } else { + temp1 = dscale[0] - *tau; + temp2 = dscale[1] - *tau; + } + a = (temp1 + temp2) * f - temp1 * temp2 * df; + b = temp1 * temp2 * f; + c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; /* Computing MAX */ - d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); - temp = max(d__1,d__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.) { - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } - if (f * eta >= 0.) { - eta = -f / df; - } + d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__); + temp = max(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } + if (f * eta >= 0.) { + eta = -f / df; + } - *tau += eta; - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.; - } + *tau += eta; + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } - fc = 0.; - erretm = 0.; - df = 0.; - ddf = 0.; - for (i__ = 1; i__ <= 3; ++i__) { - if (dscale[i__ - 1] - *tau != 0.) { - temp = 1. / (dscale[i__ - 1] - *tau); - temp1 = zscale[i__ - 1] * temp; - temp2 = temp1 * temp; - temp3 = temp2 * temp; - temp4 = temp1 / dscale[i__ - 1]; - fc += temp4; - erretm += abs(temp4); - df += temp2; - ddf += temp3; - } else { - goto L60; - } + fc = 0.; + erretm = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + if (dscale[i__ - 1] - *tau != 0.) { + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + temp4 = temp1 / dscale[i__ - 1]; + fc += temp4; + erretm += abs(temp4); + df += temp2; + ddf += temp3; + } else { + goto L60; + } /* L40: */ - } - f = *finit + *tau * fc; - erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; - if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) - { - goto L60; - } - if (f <= 0.) { - lbd = *tau; - } else { - ubd = *tau; - } + } + f = *finit + *tau * fc; + erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; + if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) + { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } /* L50: */ } *info = 1; @@ -450,7 +450,7 @@ L60: /* Undo scaling */ if (scale) { - *tau *= sclinv; + *tau *= sclinv; } return 0; @@ -459,5 +459,5 @@ L60: } /* dlaed6_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed7.cpp b/lib/linalg/dlaed7.cpp index 367bf37a46..1751f93559 100644 --- a/lib/linalg/dlaed7.cpp +++ b/lib/linalg/dlaed7.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed7.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -282,12 +282,12 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, - doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer - *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer * - perm, integer *givptr, integer *givcol, doublereal *givnum, - doublereal *work, integer *iwork, integer *info) +/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, + doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer + *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer * + perm, integer *givptr, integer *givcol, doublereal *givnum, + doublereal *work, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; @@ -297,25 +297,25 @@ f"> */ /* Local variables */ integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer indxc, indxp; - extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, integer *, - doublereal *, integer *, integer *, integer *), dlaed9_(integer *, - integer *, integer *, integer *, doublereal *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, integer *), dlaeda_(integer *, integer *, integer *, - integer *, integer *, integer *, integer *, integer *, doublereal - *, doublereal *, integer *, doublereal *, doublereal *, integer *) - ; + extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *), dlaed9_(integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dlaeda_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, doublereal *, integer *, doublereal *, doublereal *, integer *) + ; integer idlmda; - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen); integer coltyp; @@ -362,26 +362,26 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*icompq == 1 && *qsiz < *n) { - *info = -3; + *info = -3; } else if (*ldq < max(1,*n)) { - *info = -9; + *info = -9; } else if (min(1,*n) > *cutpnt || *n < *cutpnt) { - *info = -12; + *info = -12; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED7", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED7", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* The following values are for bookkeeping purposes only. They are */ @@ -389,9 +389,9 @@ f"> */ /* used by a particular array in DLAED8 and DLAED9. */ if (*icompq == 1) { - ldq2 = *qsiz; + ldq2 = *qsiz; } else { - ldq2 = *n; + ldq2 = *n; } iz = 1; @@ -411,64 +411,64 @@ f"> */ ptr = pow_ii(&c__2, tlvls) + 1; i__1 = *curlvl - 1; for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *tlvls - i__; - ptr += pow_ii(&c__2, &i__2); + i__2 = *tlvls - i__; + ptr += pow_ii(&c__2, &i__2); /* L10: */ } curr = ptr + *curpbm; dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & - givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz - + *n], info); + givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz + + *n], info); /* When solving the final problem, we no longer need the stored data, */ /* so we will overwrite the data from this level onto the previously */ /* used storage space. */ if (*curlvl == *tlvls) { - qptr[curr] = 1; - prmptr[curr] = 1; - givptr[curr] = 1; + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; } /* Sort and Deflate eigenvalues. */ - dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, - cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & - perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) - + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ - indx], info); + dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, + cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & + perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) + + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ + indx], info); prmptr[curr + 1] = prmptr[curr] + *n; givptr[curr + 1] += givptr[curr]; /* Solve Secular Equation. */ if (k != 0) { - dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], - &work[iw], &qstore[qptr[curr]], &k, info); - if (*info != 0) { - goto L30; - } - if (*icompq == 1) { - dgemm_((char *)"N", (char *)"N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ - qptr[curr]], &k, &c_b11, &q[q_offset], ldq, (ftnlen)1, ( - ftnlen)1); - } + dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], + &work[iw], &qstore[qptr[curr]], &k, info); + if (*info != 0) { + goto L30; + } + if (*icompq == 1) { + dgemm_((char *)"N", (char *)"N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ + qptr[curr]], &k, &c_b11, &q[q_offset], ldq, (ftnlen)1, ( + ftnlen)1); + } /* Computing 2nd power */ - i__1 = k; - qptr[curr + 1] = qptr[curr] + i__1 * i__1; + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; /* Prepare the INDXQ sorting permutation. */ - n1 = k; - n2 = *n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); } else { - qptr[curr + 1] = qptr[curr]; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indxq[i__] = i__; + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; /* L20: */ - } + } } L30: @@ -479,5 +479,5 @@ L30: } /* dlaed7_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed8.cpp b/lib/linalg/dlaed8.cpp index 263bea75d5..8d1a7ae4b3 100644 --- a/lib/linalg/dlaed8.cpp +++ b/lib/linalg/dlaed8.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed8.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -263,12 +263,12 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, - doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, - doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer - *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer - *indx, integer *info) +/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer + *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, + doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, + doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer + *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer + *indx, integer *info) { /* System generated locals */ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; @@ -284,17 +284,17 @@ f"> */ integer k2, n1, n2, jp, n1p1; doublereal eps, tau, tol; integer jlam, imax, jmax; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *), dscal_( - integer *, doublereal *, doublereal *, integer *), dcopy_(integer - *, doublereal *, integer *, doublereal *, integer *); - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *), dscal_( + integer *, doublereal *, doublereal *, integer *), dcopy_(integer + *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), dlacpy_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -345,22 +345,22 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*icompq == 1 && *qsiz < *n) { - *info = -4; + *info = -4; } else if (*ldq < max(1,*n)) { - *info = -7; + *info = -7; } else if (*cutpnt < min(1,*n) || *cutpnt > *n) { - *info = -10; + *info = -10; } else if (*ldq2 < max(1,*n)) { - *info = -14; + *info = -14; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED8", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED8", &i__1, (ftnlen)6); + return 0; } /* Need to initialize GIVPTR to O here in case of quick exit */ @@ -373,7 +373,7 @@ f"> */ /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } n1 = *cutpnt; @@ -381,7 +381,7 @@ f"> */ n1p1 = n1 + 1; if (*rho < 0.) { - dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); } /* Normalize z so that norm(z) = 1 */ @@ -389,7 +389,7 @@ f"> */ t = 1. / sqrt(2.); i__1 = *n; for (j = 1; j <= i__1; ++j) { - indx[j] = j; + indx[j] = j; /* L10: */ } dscal_(n, &t, &z__[1], &c__1); @@ -399,13 +399,13 @@ f"> */ i__1 = *n; for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { - indxq[i__] += *cutpnt; + indxq[i__] += *cutpnt; /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = d__[indxq[i__]]; - w[i__] = z__[indxq[i__]]; + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; /* L30: */ } i__ = 1; @@ -413,8 +413,8 @@ f"> */ dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = dlamda[indx[i__]]; - z__[i__] = w[indx[i__]]; + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; /* L40: */ } @@ -430,25 +430,25 @@ f"> */ /* elements in D. */ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { - *k = 0; - if (*icompq == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - perm[j] = indxq[indx[j]]; + *k = 0; + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; /* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - perm[j] = indxq[indx[j]]; - dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 - + 1], &c__1); + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); /* L60: */ - } - dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, - (ftnlen)1); - } - return 0; + } + dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, + (ftnlen)1); + } + return 0; } /* If there are multiple eigenvalues then the problem deflates. Here */ @@ -461,90 +461,90 @@ f"> */ k2 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { - if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - indxp[k2] = j; - if (j == *n) { - goto L110; - } - } else { - jlam = j; - goto L80; - } + --k2; + indxp[k2] = j; + if (j == *n) { + goto L110; + } + } else { + jlam = j; + goto L80; + } /* L70: */ } L80: ++j; if (j > *n) { - goto L100; + goto L100; } if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - indxp[k2] = j; + --k2; + indxp[k2] = j; } else { /* Check if eigenvalues are close enough to allow deflation. */ - s = z__[jlam]; - c__ = z__[j]; + s = z__[jlam]; + c__ = z__[j]; /* Find sqrt(a**2+b**2) without overflow or */ /* destructive underflow. */ - tau = dlapy2_(&c__, &s); - t = d__[j] - d__[jlam]; - c__ /= tau; - s = -s / tau; - if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { /* Deflation is possible. */ - z__[j] = tau; - z__[jlam] = 0.; + z__[j] = tau; + z__[jlam] = 0.; /* Record the appropriate Givens rotation */ - ++(*givptr); - givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; - givcol[(*givptr << 1) + 2] = indxq[indx[j]]; - givnum[(*givptr << 1) + 1] = c__; - givnum[(*givptr << 1) + 2] = s; - if (*icompq == 1) { - drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ - indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); - } - t = d__[jlam] * c__ * c__ + d__[j] * s * s; - d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; - d__[jlam] = t; - --k2; - i__ = 1; + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*icompq == 1) { + drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ + indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + } + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; L90: - if (k2 + i__ <= *n) { - if (d__[jlam] < d__[indxp[k2 + i__]]) { - indxp[k2 + i__ - 1] = indxp[k2 + i__]; - indxp[k2 + i__] = jlam; - ++i__; - goto L90; - } else { - indxp[k2 + i__ - 1] = jlam; - } - } else { - indxp[k2 + i__ - 1] = jlam; - } - jlam = j; - } else { - ++(*k); - w[*k] = z__[jlam]; - dlamda[*k] = d__[jlam]; - indxp[*k] = jlam; - jlam = j; - } + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } } goto L80; L100: @@ -564,39 +564,39 @@ L110: /* while those which were deflated go into the last N - K slots. */ if (*icompq == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jp = indxp[j]; - dlamda[j] = d__[jp]; - perm[j] = indxq[indx[jp]]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; /* L120: */ - } + } } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jp = indxp[j]; - dlamda[j] = d__[jp]; - perm[j] = indxq[indx[jp]]; - dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] - , &c__1); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] + , &c__1); /* L130: */ - } + } } /* The deflated eigenvalues and their corresponding vectors go back */ /* into the last N - K slots of D and Q respectively. */ if (*k < *n) { - if (*icompq == 0) { - i__1 = *n - *k; - dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - } else { - i__1 = *n - *k; - dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = *n - *k; - dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* - k + 1) * q_dim1 + 1], ldq, (ftnlen)1); - } + if (*icompq == 0) { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + } else { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq, (ftnlen)1); + } } return 0; @@ -606,5 +606,5 @@ L110: } /* dlaed8_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaed9.cpp b/lib/linalg/dlaed9.cpp index f74b8f5bc0..d6a4f8bca3 100644 --- a/lib/linalg/dlaed9.cpp +++ b/lib/linalg/dlaed9.cpp @@ -1,13 +1,13 @@ /* fortran/dlaed9.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -176,10 +176,10 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal * - rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, - integer *info) +/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, + integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal * + rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, + integer *info) { /* System generated locals */ integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; @@ -192,10 +192,10 @@ f"> */ integer i__, j; doublereal temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dlaed4_(integer *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dlaed4_(integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); extern doublereal dlamc3_(doublereal *, doublereal *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -238,28 +238,28 @@ f"> */ *info = 0; if (*k < 0) { - *info = -1; + *info = -1; } else if (*kstart < 1 || *kstart > max(1,*k)) { - *info = -2; + *info = -2; } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) { - *info = -3; + *info = -3; } else if (*n < *k) { - *info = -4; + *info = -4; } else if (*ldq < max(1,*k)) { - *info = -7; + *info = -7; } else if (*lds < max(1,*k)) { - *info = -12; + *info = -12; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAED9", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAED9", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*k == 0) { - return 0; + return 0; } /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ @@ -281,34 +281,34 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; /* L10: */ } i__1 = *kstop; for (j = *kstart; j <= i__1; ++j) { - dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], - info); + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); /* If the zero finder fails, the computation is terminated. */ - if (*info != 0) { - goto L120; - } + if (*info != 0) { + goto L120; + } /* L20: */ } if (*k == 1 || *k == 2) { - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *k; - for (j = 1; j <= i__2; ++j) { - s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *k; + for (j = 1; j <= i__2; ++j) { + s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; /* L30: */ - } + } /* L40: */ - } - goto L120; + } + goto L120; } /* Compute updated W. */ @@ -321,22 +321,22 @@ f"> */ dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); i__1 = *k; for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); /* L50: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); /* L60: */ - } + } /* L70: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = sqrt(-w[i__]); - w[i__] = d_sign(&d__1, &s[i__ + s_dim1]); + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__1, &s[i__ + s_dim1]); /* L80: */ } @@ -344,17 +344,17 @@ f"> */ i__1 = *k; for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; /* L90: */ - } - temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; + } + temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; /* L100: */ - } + } /* L110: */ } @@ -366,5 +366,5 @@ L120: } /* dlaed9_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaeda.cpp b/lib/linalg/dlaeda.cpp index f487609f82..39b4c8810f 100644 --- a/lib/linalg/dlaeda.cpp +++ b/lib/linalg/dlaeda.cpp @@ -1,13 +1,13 @@ /* fortran/dlaeda.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,10 +189,10 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, - doublereal *z__, doublereal *ztemp, integer *info) +/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, + integer *curpbm, integer *prmptr, integer *perm, integer *givptr, + integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, + doublereal *z__, doublereal *ztemp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3; @@ -203,14 +203,14 @@ f"> */ /* Local variables */ integer i__, k, mid, ptr; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1; - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, - doublereal *, integer *, doublereal *, integer *), xerbla_(char *, - integer *, ftnlen); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *), xerbla_(char *, + integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -251,18 +251,18 @@ f"> */ *info = 0; if (*n < 0) { - *info = -1; + *info = -1; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Determine location of first number in second half. */ @@ -284,19 +284,19 @@ f"> */ /* roots. */ bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5); - bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) + - .5); + bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) + + .5); i__1 = mid - bsiz1 - 1; for (k = 1; k <= i__1; ++k) { - z__[k] = 0.; + z__[k] = 0.; /* L10: */ } dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & - c__1); + c__1); dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); i__1 = *n; for (k = mid + bsiz2; k <= i__1; ++k) { - z__[k] = 0.; + z__[k] = 0.; /* L20: */ } @@ -307,43 +307,43 @@ f"> */ ptr = pow_ii(&c__2, tlvls) + 1; i__1 = *curlvl - 1; for (k = 1; k <= i__1; ++k) { - i__2 = *curlvl - k; - i__3 = *curlvl - k - 1; - curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - - 1; - psiz1 = prmptr[curr + 1] - prmptr[curr]; - psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; - zptr1 = mid - psiz1; + i__2 = *curlvl - k; + i__3 = *curlvl - k - 1; + curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - + 1; + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + zptr1 = mid - psiz1; /* Apply Givens at CURR and CURR+1 */ - i__2 = givptr[curr + 1] - 1; - for (i__ = givptr[curr]; i__ <= i__2; ++i__) { - drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & - z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( - i__ << 1) + 1], &givnum[(i__ << 1) + 2]); + i__2 = givptr[curr + 1] - 1; + for (i__ = givptr[curr]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & + z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( + i__ << 1) + 1], &givnum[(i__ << 1) + 2]); /* L30: */ - } - i__2 = givptr[curr + 2] - 1; - for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { - drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ - mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << - 1) + 1], &givnum[(i__ << 1) + 2]); + } + i__2 = givptr[curr + 2] - 1; + for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ + mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << + 1) + 1], &givnum[(i__ << 1) + 2]); /* L40: */ - } - psiz1 = prmptr[curr + 1] - prmptr[curr]; - psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; - i__2 = psiz1 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; + } + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + i__2 = psiz1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; /* L50: */ - } - i__2 = psiz2 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - - 1]; + } + i__2 = psiz2 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - + 1]; /* L60: */ - } + } /* Multiply Blocks at CURR and CURR+1 */ @@ -351,27 +351,27 @@ f"> */ /* the SQRT in case the machine underestimates one of these */ /* square roots. */ - bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + - .5); - bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1]) - ) + .5); - if (bsiz1 > 0) { - dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & - ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1, (ftnlen)1); - } - i__2 = psiz1 - bsiz1; - dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); - if (bsiz2 > 0) { - dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & - ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1, ( - ftnlen)1); - } - i__2 = psiz2 - bsiz2; - dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & - c__1); + bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + + .5); + bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1]) + ) + .5); + if (bsiz1 > 0) { + dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & + ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1, (ftnlen)1); + } + i__2 = psiz1 - bsiz1; + dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); + if (bsiz2 > 0) { + dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & + ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1, ( + ftnlen)1); + } + i__2 = psiz2 - bsiz2; + dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & + c__1); - i__2 = *tlvls - k; - ptr += pow_ii(&c__2, &i__2); + i__2 = *tlvls - k; + ptr += pow_ii(&c__2, &i__2); /* L70: */ } @@ -382,5 +382,5 @@ f"> */ } /* dlaeda_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaev2.cpp b/lib/linalg/dlaev2.cpp index 32f4eb5424..21bdbebe69 100644 --- a/lib/linalg/dlaev2.cpp +++ b/lib/linalg/dlaev2.cpp @@ -1,13 +1,13 @@ /* fortran/dlaev2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -136,8 +136,8 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1) +/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1) { /* System generated locals */ doublereal d__1; @@ -176,81 +176,81 @@ f"> */ tb = *b + *b; ab = abs(tb); if (abs(*a) > abs(*c__)) { - acmx = *a; - acmn = *c__; + acmx = *a; + acmn = *c__; } else { - acmx = *c__; - acmn = *a; + acmx = *c__; + acmn = *a; } if (adf > ab) { /* Computing 2nd power */ - d__1 = ab / adf; - rt = adf * sqrt(d__1 * d__1 + 1.); + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); } else if (adf < ab) { /* Computing 2nd power */ - d__1 = adf / ab; - rt = ab * sqrt(d__1 * d__1 + 1.); + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); } else { /* Includes case AB=ADF=0 */ - rt = ab * sqrt(2.); + rt = ab * sqrt(2.); } if (sm < 0.) { - *rt1 = (sm - rt) * .5; - sgn1 = -1; + *rt1 = (sm - rt) * .5; + sgn1 = -1; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.) { - *rt1 = (sm + rt) * .5; - sgn1 = 1; + *rt1 = (sm + rt) * .5; + sgn1 = 1; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { /* Includes case RT1 = RT2 = 0 */ - *rt1 = rt * .5; - *rt2 = rt * -.5; - sgn1 = 1; + *rt1 = rt * .5; + *rt2 = rt * -.5; + sgn1 = 1; } /* Compute the eigenvector */ if (df >= 0.) { - cs = df + rt; - sgn2 = 1; + cs = df + rt; + sgn2 = 1; } else { - cs = df - rt; - sgn2 = -1; + cs = df - rt; + sgn2 = -1; } acs = abs(cs); if (acs > ab) { - ct = -tb / cs; - *sn1 = 1. / sqrt(ct * ct + 1.); - *cs1 = ct * *sn1; + ct = -tb / cs; + *sn1 = 1. / sqrt(ct * ct + 1.); + *cs1 = ct * *sn1; } else { - if (ab == 0.) { - *cs1 = 1.; - *sn1 = 0.; - } else { - tn = -cs / tb; - *cs1 = 1. / sqrt(tn * tn + 1.); - *sn1 = tn * *cs1; - } + if (ab == 0.) { + *cs1 = 1.; + *sn1 = 0.; + } else { + tn = -cs / tb; + *cs1 = 1. / sqrt(tn * tn + 1.); + *sn1 = tn * *cs1; + } } if (sgn1 == sgn2) { - tn = *cs1; - *cs1 = -(*sn1); - *sn1 = tn; + tn = *cs1; + *cs1 = -(*sn1); + *sn1 = tn; } return 0; @@ -259,5 +259,5 @@ f"> */ } /* dlaev2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlals0.cpp b/lib/linalg/dlals0.cpp index ce36d7d553..9dfb826915 100644 --- a/lib/linalg/dlals0.cpp +++ b/lib/linalg/dlals0.cpp @@ -1,13 +1,13 @@ /* fortran/dlals0.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -291,17 +291,17 @@ f"> */ /* > Osni Marques, LBNL/NERSC, USA \n */ /* ===================================================================== */ -/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal - *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal * - poles, doublereal *difl, doublereal *difr, doublereal *z__, integer * - k, doublereal *c__, doublereal *s, doublereal *work, integer *info) +/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal + *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal * + poles, doublereal *difl, doublereal *difr, doublereal *z__, integer * + k, doublereal *c__, doublereal *s, doublereal *work, integer *info) { /* System generated locals */ - integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, - difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, - poles_offset, i__1, i__2; + integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, + difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, + poles_offset, i__1, i__2; doublereal d__1; /* Local variables */ @@ -309,22 +309,22 @@ f"> */ doublereal dj; integer nlp1; doublereal temp; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal diflj, difrj, dsigj; - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, - doublereal *, integer *, doublereal *, integer *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *); extern doublereal dlamc3_(doublereal *, doublereal *); - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer - *, doublereal *, integer *, doublereal *, integer *, ftnlen), - xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, ftnlen), + xerbla_(char *, integer *, ftnlen); doublereal dsigjp; @@ -382,32 +382,32 @@ f"> */ n = *nl + *nr + 1; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*nl < 1) { - *info = -2; + *info = -2; } else if (*nr < 1) { - *info = -3; + *info = -3; } else if (*sqre < 0 || *sqre > 1) { - *info = -4; + *info = -4; } else if (*nrhs < 1) { - *info = -5; + *info = -5; } else if (*ldb < n) { - *info = -7; + *info = -7; } else if (*ldbx < n) { - *info = -9; + *info = -9; } else if (*givptr < 0) { - *info = -11; + *info = -11; } else if (*ldgcol < n) { - *info = -13; + *info = -13; } else if (*ldgnum < n) { - *info = -15; + *info = -15; } else if (*k < 1) { - *info = -20; + *info = -20; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLALS0", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLALS0", &i__1, (ftnlen)6); + return 0; } m = n + *sqre; @@ -419,91 +419,91 @@ f"> */ /* Step (1L): apply back the Givens rotations performed. */ - i__1 = *givptr; - for (i__ = 1; i__ <= i__1; ++i__) { - drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & - b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + - (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); + i__1 = *givptr; + for (i__ = 1; i__ <= i__1; ++i__) { + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); /* L10: */ - } + } /* Step (2L): permute rows of B. */ - dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], - ldbx); + dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], + ldbx); /* L20: */ - } + } /* Step (3L): apply the inverse of the left singular vector */ /* matrix to BX. */ - if (*k == 1) { - dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); - if (z__[1] < 0.) { - dscal_(nrhs, &c_b5, &b[b_offset], ldb); - } - } else { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - diflj = difl[j]; - dj = poles[j + poles_dim1]; - dsigj = -poles[j + (poles_dim1 << 1)]; - if (j < *k) { - difrj = -difr[j + difr_dim1]; - dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; - } - if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { - work[j] = 0.; - } else { - work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / - (poles[j + (poles_dim1 << 1)] + dj); - } - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == - 0.) { - work[i__] = 0.; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & - dsigj) - diflj) / (poles[i__ + (poles_dim1 << - 1)] + dj); - } + if (*k == 1) { + dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.) { + dscal_(nrhs, &c_b5, &b[b_offset], ldb); + } + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = poles[j + poles_dim1]; + dsigj = -poles[j + (poles_dim1 << 1)]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; + } + if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { + work[j] = 0.; + } else { + work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / + (poles[j + (poles_dim1 << 1)] + dj); + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigj) - diflj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } /* L30: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == - 0.) { - work[i__] = 0.; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & - dsigjp) + difrj) / (poles[i__ + (poles_dim1 << - 1)] + dj); - } + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigjp) + difrj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } /* L40: */ - } - work[1] = -1.; - temp = dnrm2_(k, &work[1], &c__1); - dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & - c__1, &c_b13, &b[j + b_dim1], ldb, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + - b_dim1], ldb, info, (ftnlen)1); + } + work[1] = -1.; + temp = dnrm2_(k, &work[1], &c__1); + dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & + c__1, &c_b13, &b[j + b_dim1], ldb, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + + b_dim1], ldb, info, (ftnlen)1); /* L50: */ - } - } + } + } /* Move the deflated rows of BX to B also. */ - if (*k < max(m,n)) { - i__1 = n - *k; - dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 - + b_dim1], ldb, (ftnlen)1); - } + if (*k < max(m,n)) { + i__1 = n - *k; + dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + + b_dim1], ldb, (ftnlen)1); + } } else { /* Apply back the right orthogonal transformations. */ @@ -511,84 +511,84 @@ f"> */ /* Step (1R): apply back the new right singular vector matrix */ /* to B. */ - if (*k == 1) { - dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); - } else { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dsigj = poles[j + (poles_dim1 << 1)]; - if (z__[j] == 0.) { - work[j] = 0.; - } else { - work[j] = -z__[j] / difl[j] / (dsigj + poles[j + - poles_dim1]) / difr[j + (difr_dim1 << 1)]; - } - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - if (z__[j] == 0.) { - work[i__] = 0.; - } else { - d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; - work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ - i__ + difr_dim1]) / (dsigj + poles[i__ + - poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; - } + if (*k == 1) { + dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dsigj = poles[j + (poles_dim1 << 1)]; + if (z__[j] == 0.) { + work[j] = 0.; + } else { + work[j] = -z__[j] / difl[j] / (dsigj + poles[j + + poles_dim1]) / difr[j + (difr_dim1 << 1)]; + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ + i__ + difr_dim1]) / (dsigj + poles[i__ + + poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; + } /* L60: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - if (z__[j] == 0.) { - work[i__] = 0.; - } else { - d__1 = -poles[i__ + (poles_dim1 << 1)]; - work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ - i__]) / (dsigj + poles[i__ + poles_dim1]) / - difr[i__ + (difr_dim1 << 1)]; - } + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ + i__]) / (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } /* L70: */ - } - dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & - c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1); + } + dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & + c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1); /* L80: */ - } - } + } + } /* Step (2R): if SQRE = 1, apply back the rotation that is */ /* related to the right null space of the subproblem. */ - if (*sqre == 1) { - dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); - drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, - s); - } - if (*k < max(m,n)) { - i__1 = n - *k; - dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + - bx_dim1], ldbx, (ftnlen)1); - } + if (*sqre == 1) { + dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, + s); + } + if (*k < max(m,n)) { + i__1 = n - *k; + dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + + bx_dim1], ldbx, (ftnlen)1); + } /* Step (3R): permute rows of B. */ - dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); - if (*sqre == 1) { - dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); - } - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], - ldb); + dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], + ldb); /* L90: */ - } + } /* Step (4R): apply back the Givens rotations performed. */ - for (i__ = *givptr; i__ >= 1; --i__) { - d__1 = -givnum[i__ + givnum_dim1]; - drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & - b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + - (givnum_dim1 << 1)], &d__1); + for (i__ = *givptr; i__ >= 1; --i__) { + d__1 = -givnum[i__ + givnum_dim1]; + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &d__1); /* L100: */ - } + } } return 0; @@ -598,5 +598,5 @@ f"> */ } /* dlals0_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlalsa.cpp b/lib/linalg/dlalsa.cpp index 7c09a46de3..e68dabd8dd 100644 --- a/lib/linalg/dlalsa.cpp +++ b/lib/linalg/dlalsa.cpp @@ -1,13 +1,13 @@ /* fortran/dlalsa.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -286,40 +286,40 @@ f"> */ /* > Osni Marques, LBNL/NERSC, USA \n */ /* ===================================================================== */ -/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer * - ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, - doublereal *difl, doublereal *difr, doublereal *z__, doublereal * - poles, integer *givptr, integer *givcol, integer *ldgcol, integer * - perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal * - work, integer *iwork, integer *info) +/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, + integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer * + ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, + doublereal *difl, doublereal *difr, doublereal *z__, doublereal * + poles, integer *givptr, integer *givcol, integer *ldgcol, integer * + perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal * + work, integer *iwork, integer *info) { /* System generated locals */ - integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, - b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, - difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, - u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, - i__2; + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, + b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, + difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, + u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, + i__2; /* Builtin functions */ integer pow_ii(integer *, integer *); /* Local variables */ - integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, - nlp1, lvl2, nrp1, nlvl, sqre; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, + nlp1, lvl2, nrp1, nlvl, sqre; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); integer inode, ndiml, ndimr; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dlals0_(integer *, integer *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - integer *), dlasdt_(integer *, integer *, integer *, integer *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dlals0_(integer *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *), dlasdt_(integer *, integer *, integer *, integer *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -388,26 +388,26 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*smlsiz < 3) { - *info = -2; + *info = -2; } else if (*n < *smlsiz) { - *info = -3; + *info = -3; } else if (*nrhs < 1) { - *info = -4; + *info = -4; } else if (*ldb < *n) { - *info = -6; + *info = -6; } else if (*ldbx < *n) { - *info = -8; + *info = -8; } else if (*ldu < *n) { - *info = -10; + *info = -10; } else if (*ldgcol < *n) { - *info = -19; + *info = -19; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLALSA", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLALSA", &i__1, (ftnlen)6); + return 0; } /* Book-keeping and setting up the computation tree. */ @@ -416,14 +416,14 @@ f"> */ ndiml = inode + *n; ndimr = ndiml + *n; - dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); /* The following code applies back the left singular vector factors. */ /* For applying back the right singular vector factors, go to 50. */ if (*icompq == 1) { - goto L50; + goto L50; } /* The nodes on the bottom level of the tree were solved */ @@ -441,18 +441,18 @@ f"> */ /* NLF: starting row of the left subproblem */ /* NRF: starting row of the right subproblem */ - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nr = iwork[ndimr + i1]; - nlf = ic - nl; - nrf = ic + 1; - dgemm_((char *)"T", (char *)"N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf - + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, (ftnlen)1, ( - ftnlen)1); - dgemm_((char *)"T", (char *)"N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf - + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, (ftnlen)1, ( - ftnlen)1); + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + dgemm_((char *)"T", (char *)"N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf + + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, (ftnlen)1, ( + ftnlen)1); + dgemm_((char *)"T", (char *)"N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf + + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, (ftnlen)1, ( + ftnlen)1); /* L10: */ } @@ -461,8 +461,8 @@ f"> */ i__1 = nd; for (i__ = 1; i__ <= i__1; ++i__) { - ic = iwork[inode + i__ - 1]; - dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); + ic = iwork[inode + i__ - 1]; + dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); /* L20: */ } @@ -473,37 +473,37 @@ f"> */ sqre = 0; for (lvl = nlvl; lvl >= 1; --lvl) { - lvl2 = (lvl << 1) - 1; + lvl2 = (lvl << 1) - 1; /* find the first node LF and last node LL on */ /* the current level LVL */ - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__1 = lvl - 1; - lf = pow_ii(&c__2, &i__1); - ll = (lf << 1) - 1; - } - i__1 = ll; - for (i__ = lf; i__ <= i__1; ++i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - --j; - dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & - b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & - givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & - givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * - poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + - lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ - j], &s[j], &work[1], info); + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + --j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & + b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); /* L30: */ - } + } /* L40: */ } goto L90; @@ -518,42 +518,42 @@ L50: j = 0; i__1 = nlvl; for (lvl = 1; lvl <= i__1; ++lvl) { - lvl2 = (lvl << 1) - 1; + lvl2 = (lvl << 1) - 1; /* Find the first node LF and last node LL on */ /* the current level LVL. */ - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__2 = lvl - 1; - lf = pow_ii(&c__2, &i__2); - ll = (lf << 1) - 1; - } - i__2 = lf; - for (i__ = ll; i__ >= i__2; --i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - if (i__ == ll) { - sqre = 0; - } else { - sqre = 1; - } - ++j; - dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ - nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & - givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & - givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * - poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + - lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ - j], &s[j], &work[1], info); + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__2 = lvl - 1; + lf = pow_ii(&c__2, &i__2); + ll = (lf << 1) - 1; + } + i__2 = lf; + for (i__ = ll; i__ >= i__2; --i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqre = 0; + } else { + sqre = 1; + } + ++j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ + nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); /* L60: */ - } + } /* L70: */ } @@ -564,24 +564,24 @@ L50: ndb1 = (nd + 1) / 2; i__1 = nd; for (i__ = ndb1; i__ <= i__1; ++i__) { - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nr = iwork[ndimr + i1]; - nlp1 = nl + 1; - if (i__ == nd) { - nrp1 = nr; - } else { - nrp1 = nr + 1; - } - nlf = ic - nl; - nrf = ic + 1; - dgemm_((char *)"T", (char *)"N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & - b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, ( - ftnlen)1, (ftnlen)1); - dgemm_((char *)"T", (char *)"N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & - b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, ( - ftnlen)1, (ftnlen)1); + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlp1 = nl + 1; + if (i__ == nd) { + nrp1 = nr; + } else { + nrp1 = nr + 1; + } + nlf = ic - nl; + nrf = ic + 1; + dgemm_((char *)"T", (char *)"N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & + b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx, ( + ftnlen)1, (ftnlen)1); + dgemm_((char *)"T", (char *)"N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & + b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx, ( + ftnlen)1, (ftnlen)1); /* L80: */ } @@ -594,5 +594,5 @@ L90: } /* dlalsa_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlalsd.cpp b/lib/linalg/dlalsd.cpp index 07c3ca57f0..a141fa6992 100644 --- a/lib/linalg/dlalsd.cpp +++ b/lib/linalg/dlalsd.cpp @@ -1,13 +1,13 @@ /* fortran/dlalsd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -201,10 +201,10 @@ f"> */ /* > Osni Marques, LBNL/NERSC, USA \n */ /* ===================================================================== */ -/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer - *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, - doublereal *rcond, integer *rank, doublereal *work, integer *iwork, - integer *info, ftnlen uplo_len) +/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer + *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, + doublereal *rcond, integer *rank, doublereal *work, integer *iwork, + integer *info, ftnlen uplo_len) { /* System generated locals */ integer b_dim1, b_offset, i__1, i__2; @@ -227,44 +227,44 @@ f"> */ integer difl, difr; doublereal rcnd; integer perm, nsub; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); integer nlvl, sqre, bxst; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), - dcopy_(integer *, doublereal *, integer *, doublereal *, integer - *); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer + *); integer poles, sizei, nsize, nwork, icmpq1, icmpq2; extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *, integer *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *), dlalsa_(integer *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, integer *), dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *), dlalsa_(integer *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen); extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer - *, integer *, integer *, doublereal *, doublereal *, doublereal *, - integer *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, ftnlen), dlacpy_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen), dlartg_(doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *), dlaset_(char *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, ftnlen), - xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer + *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, ftnlen), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), dlartg_(doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *), dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, ftnlen), + xerbla_(char *, integer *, ftnlen); integer givcol; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *, ftnlen); doublereal orgnrm; integer givnum, givptr, smlszp; @@ -307,16 +307,16 @@ f"> */ *info = 0; if (*n < 0) { - *info = -3; + *info = -3; } else if (*nrhs < 1) { - *info = -4; + *info = -4; } else if (*ldb < 1 || *ldb < *n) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLALSD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLALSD", &i__1, (ftnlen)6); + return 0; } eps = dlamch_((char *)"Epsilon", (ftnlen)7); @@ -324,9 +324,9 @@ f"> */ /* Set up the tolerance. */ if (*rcond <= 0. || *rcond >= 1.) { - rcnd = eps; + rcnd = eps; } else { - rcnd = *rcond; + rcnd = *rcond; } *rank = 0; @@ -334,52 +334,52 @@ f"> */ /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } else if (*n == 1) { - if (d__[1] == 0.) { - dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, ( - ftnlen)1); - } else { - *rank = 1; - dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ - b_offset], ldb, info, (ftnlen)1); - d__[1] = abs(d__[1]); - } - return 0; + if (d__[1] == 0.) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, ( + ftnlen)1); + } else { + *rank = 1; + dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ + b_offset], ldb, info, (ftnlen)1); + d__[1] = abs(d__[1]); + } + return 0; } /* Rotate the matrix if it is lower bidiagonal. */ if (*(unsigned char *)uplo == 'L') { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (*nrhs == 1) { - drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & - c__1, &cs, &sn); - } else { - work[(i__ << 1) - 1] = cs; - work[i__ * 2] = sn; - } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (*nrhs == 1) { + drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & + c__1, &cs, &sn); + } else { + work[(i__ << 1) - 1] = cs; + work[i__ * 2] = sn; + } /* L10: */ - } - if (*nrhs > 1) { - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *n - 1; - for (j = 1; j <= i__2; ++j) { - cs = work[(j << 1) - 1]; - sn = work[j * 2]; - drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * - b_dim1], &c__1, &cs, &sn); + } + if (*nrhs > 1) { + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - 1; + for (j = 1; j <= i__2; ++j) { + cs = work[(j << 1) - 1]; + sn = work[j * 2]; + drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * + b_dim1], &c__1, &cs, &sn); /* L20: */ - } + } /* L30: */ - } - } + } + } } /* Scale. */ @@ -387,58 +387,58 @@ f"> */ nm1 = *n - 1; orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); if (orgnrm == 0.) { - dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1); - return 0; + dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1); + return 0; } dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, ( - ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, - info, (ftnlen)1); + ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, + info, (ftnlen)1); /* If N is smaller than the minimum divide size SMLSIZ, then solve */ /* the problem with another solver. */ if (*n <= *smlsiz) { - nwork = *n * *n + 1; - dlaset_((char *)"A", n, n, &c_b6, &c_b11, &work[1], n, (ftnlen)1); - dlasdq_((char *)"U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & - work[1], n, &b[b_offset], ldb, &work[nwork], info, (ftnlen)1); - if (*info != 0) { - return 0; - } - tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] <= tol) { - dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb, - (ftnlen)1); - } else { - dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ - i__ + b_dim1], ldb, info, (ftnlen)1); - ++(*rank); - } + nwork = *n * *n + 1; + dlaset_((char *)"A", n, n, &c_b6, &c_b11, &work[1], n, (ftnlen)1); + dlasdq_((char *)"U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & + work[1], n, &b[b_offset], ldb, &work[nwork], info, (ftnlen)1); + if (*info != 0) { + return 0; + } + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb, + (ftnlen)1); + } else { + dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ + i__ + b_dim1], ldb, info, (ftnlen)1); + ++(*rank); + } /* L40: */ - } - dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & - c_b6, &work[nwork], n, (ftnlen)1, (ftnlen)1); - dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1); + } + dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & + c_b6, &work[nwork], n, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1); /* Unscale. */ - dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, - info, (ftnlen)1); - dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], - ldb, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, + info, (ftnlen)1); + dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], + ldb, info, (ftnlen)1); - return 0; + return 0; } /* Book-keeping and setting up some constants. */ - nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / - log(2.)) + 1; + nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / + log(2.)) + 1; smlszp = *smlsiz + 1; @@ -469,95 +469,95 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) < eps) { - d__[i__] = d_sign(&eps, &d__[i__]); - } + if ((d__1 = d__[i__], abs(d__1)) < eps) { + d__[i__] = d_sign(&eps, &d__[i__]); + } /* L50: */ } i__1 = nm1; for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { - ++nsub; - iwork[nsub] = st; + if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { + ++nsub; + iwork[nsub] = st; /* Subproblem found. First determine its size and then */ /* apply divide and conquer on it. */ - if (i__ < nm1) { + if (i__ < nm1) { /* A subproblem with E(I) small for I < NM1. */ - nsize = i__ - st + 1; - iwork[sizei + nsub - 1] = nsize; - } else if ((d__1 = e[i__], abs(d__1)) >= eps) { + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else if ((d__1 = e[i__], abs(d__1)) >= eps) { /* A subproblem with E(NM1) not too small but I = NM1. */ - nsize = *n - st + 1; - iwork[sizei + nsub - 1] = nsize; - } else { + nsize = *n - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else { /* A subproblem with E(NM1) small. This implies an */ /* 1-by-1 subproblem at D(N), which is not solved */ /* explicitly. */ - nsize = i__ - st + 1; - iwork[sizei + nsub - 1] = nsize; - ++nsub; - iwork[nsub] = *n; - iwork[sizei + nsub - 1] = 1; - dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); - } - st1 = st - 1; - if (nsize == 1) { + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + ++nsub; + iwork[nsub] = *n; + iwork[sizei + nsub - 1] = 1; + dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); + } + st1 = st - 1; + if (nsize == 1) { /* This is a 1-by-1 subproblem and is not solved */ /* explicitly. */ - dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); - } else if (nsize <= *smlsiz) { + dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { /* This is a small subproblem and is solved by DLASDQ. */ - dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], - n, (ftnlen)1); - dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ - st], &work[vt + st1], n, &work[nwork], n, &b[st + - b_dim1], ldb, &work[nwork], info, (ftnlen)1); - if (*info != 0) { - return 0; - } - dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + - st1], n, (ftnlen)1); - } else { + dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], + n, (ftnlen)1); + dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ + st], &work[vt + st1], n, &work[nwork], n, &b[st + + b_dim1], ldb, &work[nwork], info, (ftnlen)1); + if (*info != 0) { + return 0; + } + dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + + st1], n, (ftnlen)1); + } else { /* A large problem. Solve it using divide and conquer. */ - dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & - work[u + st1], n, &work[vt + st1], &iwork[k + st1], & - work[difl + st1], &work[difr + st1], &work[z__ + st1], - &work[poles + st1], &iwork[givptr + st1], &iwork[ - givcol + st1], n, &iwork[perm + st1], &work[givnum + - st1], &work[c__ + st1], &work[s + st1], &work[nwork], - &iwork[iwk], info); - if (*info != 0) { - return 0; - } - bxst = bx + st1; - dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & - work[bxst], n, &work[u + st1], n, &work[vt + st1], & - iwork[k + st1], &work[difl + st1], &work[difr + st1], - &work[z__ + st1], &work[poles + st1], &iwork[givptr + - st1], &iwork[givcol + st1], n, &iwork[perm + st1], & - work[givnum + st1], &work[c__ + st1], &work[s + st1], - &work[nwork], &iwork[iwk], info); - if (*info != 0) { - return 0; - } - } - st = i__ + 1; - } + dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & + work[u + st1], n, &work[vt + st1], &iwork[k + st1], & + work[difl + st1], &work[difr + st1], &work[z__ + st1], + &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + + st1], &work[c__ + st1], &work[s + st1], &work[nwork], + &iwork[iwk], info); + if (*info != 0) { + return 0; + } + bxst = bx + st1; + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & + work[bxst], n, &work[u + st1], n, &work[vt + st1], & + iwork[k + st1], &work[difl + st1], &work[difr + st1], + &work[z__ + st1], &work[poles + st1], &iwork[givptr + + st1], &iwork[givcol + st1], n, &iwork[perm + st1], & + work[givnum + st1], &work[c__ + st1], &work[s + st1], + &work[nwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + st = i__ + 1; + } /* L60: */ } @@ -571,15 +571,15 @@ f"> */ /* Some of the elements in D can be negative because 1-by-1 */ /* subproblems were not solved explicitly. */ - if ((d__1 = d__[i__], abs(d__1)) <= tol) { - dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, ( - ftnlen)1); - } else { - ++(*rank); - dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ - bx + i__ - 1], n, info, (ftnlen)1); - } - d__[i__] = (d__1 = d__[i__], abs(d__1)); + if ((d__1 = d__[i__], abs(d__1)) <= tol) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, ( + ftnlen)1); + } else { + ++(*rank); + dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ + bx + i__ - 1], n, info, (ftnlen)1); + } + d__[i__] = (d__1 = d__[i__], abs(d__1)); /* L70: */ } @@ -588,38 +588,38 @@ f"> */ icmpq2 = 1; i__1 = nsub; for (i__ = 1; i__ <= i__1; ++i__) { - st = iwork[i__]; - st1 = st - 1; - nsize = iwork[sizei + i__ - 1]; - bxst = bx + st1; - if (nsize == 1) { - dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); - } else if (nsize <= *smlsiz) { - dgemm_((char *)"T", (char *)"N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, - &work[bxst], n, &c_b6, &b[st + b_dim1], ldb, (ftnlen)1, ( - ftnlen)1); - } else { - dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + - b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ - k + st1], &work[difl + st1], &work[difr + st1], &work[z__ - + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ - givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], - &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ - iwk], info); - if (*info != 0) { - return 0; - } - } + st = iwork[i__]; + st1 = st - 1; + nsize = iwork[sizei + i__ - 1]; + bxst = bx + st1; + if (nsize == 1) { + dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + dgemm_((char *)"T", (char *)"N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, + &work[bxst], n, &c_b6, &b[st + b_dim1], ldb, (ftnlen)1, ( + ftnlen)1); + } else { + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + + b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ + k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], + &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ + iwk], info); + if (*info != 0) { + return 0; + } + } /* L80: */ } /* Unscale and sort the singular values. */ dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, ( - ftnlen)1); + ftnlen)1); dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, - info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, + info, (ftnlen)1); return 0; @@ -628,5 +628,5 @@ f"> */ } /* dlalsd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlamrg.cpp b/lib/linalg/dlamrg.cpp index 581a64fba7..810d1db154 100644 --- a/lib/linalg/dlamrg.cpp +++ b/lib/linalg/dlamrg.cpp @@ -1,13 +1,13 @@ /* fortran/dlamrg.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -15,7 +15,7 @@ extern "C" { #endif #include "lmp_f2c.h" -/* > \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a +/* > \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. */ /* =========== DOCUMENTATION =========== */ @@ -116,8 +116,8 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer - *dtrd1, integer *dtrd2, integer *index) +/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer + *dtrd1, integer *dtrd2, integer *index) { /* System generated locals */ integer i__1; @@ -149,50 +149,50 @@ f"> */ n1sv = *n1; n2sv = *n2; if (*dtrd1 > 0) { - ind1 = 1; + ind1 = 1; } else { - ind1 = *n1; + ind1 = *n1; } if (*dtrd2 > 0) { - ind2 = *n1 + 1; + ind2 = *n1 + 1; } else { - ind2 = *n1 + *n2; + ind2 = *n1 + *n2; } i__ = 1; /* while ( (N1SV > 0) & (N2SV > 0) ) */ L10: if (n1sv > 0 && n2sv > 0) { - if (a[ind1] <= a[ind2]) { - index[i__] = ind1; - ++i__; - ind1 += *dtrd1; - --n1sv; - } else { - index[i__] = ind2; - ++i__; - ind2 += *dtrd2; - --n2sv; - } - goto L10; + if (a[ind1] <= a[ind2]) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; + --n1sv; + } else { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; + --n2sv; + } + goto L10; } /* end while */ if (n1sv == 0) { - i__1 = n2sv; - for (n1sv = 1; n1sv <= i__1; ++n1sv) { - index[i__] = ind2; - ++i__; - ind2 += *dtrd2; + i__1 = n2sv; + for (n1sv = 1; n1sv <= i__1; ++n1sv) { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; /* L20: */ - } + } } else { /* N2SV .EQ. 0 */ - i__1 = n1sv; - for (n2sv = 1; n2sv <= i__1; ++n2sv) { - index[i__] = ind1; - ++i__; - ind1 += *dtrd1; + i__1 = n1sv; + for (n2sv = 1; n2sv <= i__1; ++n2sv) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; /* L30: */ - } + } } return 0; @@ -202,5 +202,5 @@ L10: } /* dlamrg_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlange.cpp b/lib/linalg/dlange.cpp index 1ccc6fae2b..ab88573259 100644 --- a/lib/linalg/dlange.cpp +++ b/lib/linalg/dlange.cpp @@ -1,13 +1,13 @@ /* fortran/dlange.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +/* > \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. */ /* =========== DOCUMENTATION =========== */ @@ -135,8 +135,8 @@ f"> */ /* > \ingroup doubleGEauxiliary */ /* ===================================================================== */ -doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer - *lda, doublereal *work, ftnlen norm_len) +doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer + *lda, doublereal *work, ftnlen norm_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -151,8 +151,8 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal value; extern logical disnan_(doublereal *); - extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, - doublereal *, doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -186,83 +186,83 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer /* Function Body */ if (min(*m,*n) == 0) { - value = 0.; + value = 0.; } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - if (value < temp || disnan_(&temp)) { - value = temp; - } + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } /* L10: */ - } + } /* L20: */ - } + } } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) - norm == '1') { + norm == '1') { /* Find norm1(A). */ - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); /* L30: */ - } - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L40: */ - } + } } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { /* Find normI(A). */ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; /* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); /* L60: */ - } + } /* L70: */ - } - value = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = work[i__]; - if (value < temp || disnan_(&temp)) { - value = temp; - } + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } /* L80: */ - } + } } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( - ftnlen)1, (ftnlen)1)) { + ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L90: */ - } - value = scale * sqrt(sum); + } + value = scale * sqrt(sum); } ret_val = value; @@ -273,5 +273,5 @@ doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer } /* dlange_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlanst.cpp b/lib/linalg/dlanst.cpp index 8a71bcd12d..c216660b75 100644 --- a/lib/linalg/dlanst.cpp +++ b/lib/linalg/dlanst.cpp @@ -1,13 +1,13 @@ /* fortran/dlanst.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -121,8 +121,8 @@ f"> */ /* > \ingroup OTHERauxiliary */ /* ===================================================================== */ -doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, - ftnlen norm_len) +doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, + ftnlen norm_len) { /* System generated locals */ integer i__1; @@ -137,8 +137,8 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal anorm; extern logical disnan_(doublereal *); - extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, - doublereal *, doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -170,61 +170,61 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, /* Function Body */ if (*n <= 0) { - anorm = 0.; + anorm = 0.; } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ - anorm = (d__1 = d__[*n], abs(d__1)); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - sum = (d__1 = d__[i__], abs(d__1)); - if (anorm < sum || disnan_(&sum)) { - anorm = sum; - } - sum = (d__1 = e[i__], abs(d__1)); - if (anorm < sum || disnan_(&sum)) { - anorm = sum; - } + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + sum = (d__1 = e[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } /* L10: */ - } + } } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) - norm == '1' || lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { + norm == '1' || lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { /* Find norm1(A). */ - if (*n == 1) { - anorm = abs(d__[1]); - } else { - anorm = abs(d__[1]) + abs(e[1]); - sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); - if (anorm < sum || disnan_(&sum)) { - anorm = sum; - } - i__1 = *n - 1; - for (i__ = 2; i__ <= i__1; ++i__) { - sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2) - ) + (d__3 = e[i__ - 1], abs(d__3)); - if (anorm < sum || disnan_(&sum)) { - anorm = sum; - } + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(e[1]); + sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2) + ) + (d__3 = e[i__ - 1], abs(d__3)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } /* L20: */ - } - } + } + } } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( - ftnlen)1, (ftnlen)1)) { + ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ - scale = 0.; - sum = 1.; - if (*n > 1) { - i__1 = *n - 1; - dlassq_(&i__1, &e[1], &c__1, &scale, &sum); - sum *= 2; - } - dlassq_(n, &d__[1], &c__1, &scale, &sum); - anorm = scale * sqrt(sum); + scale = 0.; + sum = 1.; + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + dlassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); } ret_val = anorm; @@ -235,5 +235,5 @@ doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, } /* dlanst_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlansy.cpp b/lib/linalg/dlansy.cpp index 1c5a1fa24c..8d3cb42b7a 100644 --- a/lib/linalg/dlansy.cpp +++ b/lib/linalg/dlansy.cpp @@ -1,13 +1,13 @@ /* fortran/dlansy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -143,8 +143,8 @@ f"> */ /* > \ingroup doubleSYauxiliary */ /* ===================================================================== */ -doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer - *lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len) +doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer + *lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -159,8 +159,8 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal value; extern logical disnan_(doublereal *); - extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, - doublereal *, doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -194,115 +194,115 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer /* Function Body */ if (*n == 0) { - value = 0.; + value = 0.; } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ - value = 0.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - if (value < sum || disnan_(&sum)) { - value = sum; - } + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L30: */ - } + } /* L40: */ - } - } + } + } } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", ( - ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { + ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ - value = 0.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; /* L50: */ - } - work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); + } + work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); /* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - sum = work[i__]; - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; /* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; /* L90: */ - } - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L100: */ - } - } + } + } } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( - ftnlen)1, (ftnlen)1)) { + ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ - scale = 0.; - sum = 1.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + scale = 0.; + sum = 1.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L110: */ - } - } else { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); /* L120: */ - } - } - sum *= 2; - i__1 = *lda + 1; - dlassq_(n, &a[a_offset], &i__1, &scale, &sum); - value = scale * sqrt(sum); + } + } + sum *= 2; + i__1 = *lda + 1; + dlassq_(n, &a[a_offset], &i__1, &scale, &sum); + value = scale * sqrt(sum); } ret_val = value; @@ -313,5 +313,5 @@ doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer } /* dlansy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlapy2.cpp b/lib/linalg/dlapy2.cpp index 6a5443d8df..d746e1f56a 100644 --- a/lib/linalg/dlapy2.cpp +++ b/lib/linalg/dlapy2.cpp @@ -1,13 +1,13 @@ /* fortran/dlapy2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -119,25 +119,25 @@ doublereal dlapy2_(doublereal *x, doublereal *y) x_is_nan__ = disnan_(x); y_is_nan__ = disnan_(y); if (x_is_nan__) { - ret_val = *x; + ret_val = *x; } if (y_is_nan__) { - ret_val = *y; + ret_val = *y; } hugeval = dlamch_((char *)"Overflow", (ftnlen)8); if (! (x_is_nan__ || y_is_nan__)) { - xabs = abs(*x); - yabs = abs(*y); - w = max(xabs,yabs); - z__ = min(xabs,yabs); - if (z__ == 0. || w > hugeval) { - ret_val = w; - } else { + xabs = abs(*x); + yabs = abs(*y); + w = max(xabs,yabs); + z__ = min(xabs,yabs); + if (z__ == 0. || w > hugeval) { + ret_val = w; + } else { /* Computing 2nd power */ - d__1 = z__ / w; - ret_val = w * sqrt(d__1 * d__1 + 1.); - } + d__1 = z__ / w; + ret_val = w * sqrt(d__1 * d__1 + 1.); + } } return ret_val; @@ -146,5 +146,5 @@ doublereal dlapy2_(doublereal *x, doublereal *y) } /* dlapy2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlapy3.cpp b/lib/linalg/dlapy3.cpp index 528afbf3d8..211f60dbf6 100644 --- a/lib/linalg/dlapy3.cpp +++ b/lib/linalg/dlapy3.cpp @@ -1,13 +1,13 @@ /* fortran/dlapy3.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,15 +128,15 @@ doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__) /* W can be zero for max(0,nan,0) */ /* adding all three entries together will make sure */ /* NaN will not disappear. */ - ret_val = xabs + yabs + zabs; + ret_val = xabs + yabs + zabs; } else { /* Computing 2nd power */ - d__1 = xabs / w; + d__1 = xabs / w; /* Computing 2nd power */ - d__2 = yabs / w; + d__2 = yabs / w; /* Computing 2nd power */ - d__3 = zabs / w; - ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); + d__3 = zabs / w; + ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); } return ret_val; @@ -145,5 +145,5 @@ doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__) } /* dlapy3_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlarf.cpp b/lib/linalg/dlarf.cpp index 5534559e63..8111d5fa2f 100644 --- a/lib/linalg/dlarf.cpp +++ b/lib/linalg/dlarf.cpp @@ -1,13 +1,13 @@ /* fortran/dlarf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -147,8 +147,8 @@ static integer c__1 = 1; /* ===================================================================== */ /* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, - integer *incv, doublereal *tau, doublereal *c__, integer *ldc, - doublereal *work, ftnlen side_len) + integer *incv, doublereal *tau, doublereal *c__, integer *ldc, + doublereal *work, ftnlen side_len) { /* System generated locals */ integer c_dim1, c_offset; @@ -157,16 +157,16 @@ static integer c__1 = 1; /* Local variables */ integer i__; logical applyleft; - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen); integer lastc, lastv; - extern integer iladlc_(integer *, integer *, doublereal *, integer *), - iladlr_(integer *, integer *, doublereal *, integer *); + extern integer iladlc_(integer *, integer *, doublereal *, integer *), + iladlr_(integer *, integer *, doublereal *, integer *); /* -- LAPACK auxiliary routine -- */ @@ -204,28 +204,28 @@ static integer c__1 = 1; if (*tau != 0.) { /* Set up variables for scanning V. LASTV begins pointing to the end */ /* of V. */ - if (applyleft) { - lastv = *m; - } else { - lastv = *n; - } - if (*incv > 0) { - i__ = (lastv - 1) * *incv + 1; - } else { - i__ = 1; - } + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } /* Look for the last non-zero row in V. */ - while(lastv > 0 && v[i__] == 0.) { - --lastv; - i__ -= *incv; - } - if (applyleft) { + while(lastv > 0 && v[i__] == 0.) { + --lastv; + i__ -= *incv; + } + if (applyleft) { /* Scan for the last non-zero column in C(1:lastv,:). */ - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - } else { + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + } else { /* Scan for the last non-zero row in C(:,1:lastv). */ - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - } + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + } } /* Note that lastc.eq.0 renders the BLAS operations null; no special */ /* case is needed at this level. */ @@ -233,36 +233,36 @@ static integer c__1 = 1; /* Form H * C */ - if (lastv > 0) { + if (lastv > 0) { /* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */ - dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & - v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)9); + dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & + v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)9); /* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T */ - d__1 = -(*tau); - dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[ - c_offset], ldc); - } + d__1 = -(*tau); + dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[ + c_offset], ldc); + } } else { /* Form C * H */ - if (lastv > 0) { + if (lastv > 0) { /* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ - dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, - &v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)12); + dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, + &v[1], incv, &c_b5, &work[1], &c__1, (ftnlen)12); /* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T */ - d__1 = -(*tau); - dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[ - c_offset], ldc); - } + d__1 = -(*tau); + dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[ + c_offset], ldc); + } } return 0; @@ -271,5 +271,5 @@ static integer c__1 = 1; } /* dlarf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlarfb.cpp b/lib/linalg/dlarfb.cpp index df15d11900..d282b19899 100644 --- a/lib/linalg/dlarfb.cpp +++ b/lib/linalg/dlarfb.cpp @@ -1,13 +1,13 @@ /* fortran/dlarfb.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -219,25 +219,25 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, doublereal *v, integer * - ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, - doublereal *work, integer *ldwork, ftnlen side_len, ftnlen trans_len, - ftnlen direct_len, ftnlen storev_len) + storev, integer *m, integer *n, integer *k, doublereal *v, integer * + ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, + doublereal *work, integer *ldwork, ftnlen side_len, ftnlen trans_len, + ftnlen direct_len, ftnlen storev_len) { /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; /* Local variables */ integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); char transt[1]; @@ -280,24 +280,24 @@ f"> */ /* Function Body */ if (*m <= 0 || *n <= 0) { - return 0; + return 0; } if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - *(unsigned char *)transt = 'T'; + *(unsigned char *)transt = 'T'; } else { - *(unsigned char *)transt = 'N'; + *(unsigned char *)transt = 'N'; } if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { /* Let V = ( V1 ) (first K rows) */ /* ( V2 ) */ /* where V1 is unit lower triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**T * C where C = ( C1 ) */ /* ( C2 ) */ @@ -306,67 +306,67 @@ f"> */ /* W := C1**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], - &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); /* L10: */ - } + } /* W := W * V1 */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*m > *k) { + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { /* W := W + C2**T * V2 */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & - c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], - ldv, &c_b14, &work[work_offset], ldwork, (ftnlen) - 9, (ftnlen)12); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & + c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], + ldv, &c_b14, &work[work_offset], ldwork, (ftnlen) + 9, (ftnlen)12); + } /* W := W * T**T or W * T */ - dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V * W**T */ - if (*m > *k) { + if (*m > *k) { /* C2 := C2 - V2 * W**T */ - i__1 = *m - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & - v[*k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( - ftnlen)12, (ftnlen)9); - } + i__1 = *m - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & + v[*k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( + ftnlen)12, (ftnlen)9); + } /* W := W * V1**T */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) - 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) + 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); /* C1 := C1 - W**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; /* L20: */ - } + } /* L30: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**T where C = ( C1 C2 ) */ @@ -374,74 +374,74 @@ f"> */ /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); /* L40: */ - } + } /* W := W * V1 */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*n > *k) { + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { /* W := W + C2 * V2 */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b14, &work[work_offset], - ldwork, (ftnlen)12, (ftnlen)12); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & + c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + + 1 + v_dim1], ldv, &c_b14, &work[work_offset], + ldwork, (ftnlen)12, (ftnlen)12); + } /* W := W * T or W * T**T */ - dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V**T */ - if (*n > *k) { + if (*n > *k) { /* C2 := C2 - W * V2**T */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & - work[work_offset], ldwork, &v[*k + 1 + v_dim1], - ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, ( - ftnlen)12, (ftnlen)9); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & + work[work_offset], ldwork, &v[*k + 1 + v_dim1], + ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, ( + ftnlen)12, (ftnlen)9); + } /* W := W * V1**T */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) - 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) + 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; /* L50: */ - } + } /* L60: */ - } - } + } + } - } else { + } else { /* Let V = ( V1 ) */ /* ( V2 ) (last K rows) */ /* where V2 is unit upper triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**T * C where C = ( C1 ) */ /* ( C2 ) */ @@ -450,67 +450,67 @@ f"> */ /* W := C2**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); /* L70: */ - } + } /* W := W * V2 */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, - &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*m > *k) { + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { /* W := W + C1**T * V1 */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork, (ftnlen)9, (ftnlen)12); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork, (ftnlen)9, (ftnlen)12); + } /* W := W * T**T or W * T */ - dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V * W**T */ - if (*m > *k) { + if (*m > *k) { /* C1 := C1 - V1 * W**T */ - i__1 = *m - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & - v[v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) - ; - } + i__1 = *m - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, & + v[v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) + ; + } /* W := W * V2**T */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & - v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & + v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); /* C2 := C2 - W**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; /* L80: */ - } + } /* L90: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**T where C = ( C1 C2 ) */ @@ -518,77 +518,77 @@ f"> */ /* W := C2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ - j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); /* L100: */ - } + } /* W := W * V2 */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, - &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*n > *k) { + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { /* W := W + C1 * V1 */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork, (ftnlen)12, ( - ftnlen)12); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, & + c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b14, &work[work_offset], ldwork, (ftnlen)12, ( + ftnlen)12); + } /* W := W * T or W * T**T */ - dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V**T */ - if (*n > *k) { + if (*n > *k) { /* C1 := C1 - W * V1**T */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & - work[work_offset], ldwork, &v[v_offset], ldv, & - c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) - ; - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, & + work[work_offset], ldwork, &v[v_offset], ldv, & + c_b14, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)9) + ; + } /* W := W * V2**T */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & - v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & + v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); /* C2 := C2 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; /* L110: */ - } + } /* L120: */ - } - } - } + } + } + } } else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { /* Let V = ( V1 V2 ) (V1: first K columns) */ /* where V1 is unit upper triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**T * C where C = ( C1 ) */ /* ( C2 ) */ @@ -597,67 +597,67 @@ f"> */ /* W := C1**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], - &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); /* L130: */ - } + } /* W := W * V1**T */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) - 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); - if (*m > *k) { + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) + 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*m > *k) { /* W := W + C2**T * V2**T */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & - c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + - 1], ldv, &c_b14, &work[work_offset], ldwork, ( - ftnlen)9, (ftnlen)9); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & + c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + + 1], ldv, &c_b14, &work[work_offset], ldwork, ( + ftnlen)9, (ftnlen)9); + } /* W := W * T**T or W * T */ - dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V**T * W**T */ - if (*m > *k) { + if (*m > *k) { /* C2 := C2 - V2**T * W**T */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[( - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], - ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( - ftnlen)9, (ftnlen)9); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[( + *k + 1) * v_dim1 + 1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, ( + ftnlen)9, (ftnlen)9); + } /* W := W * V1 */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); /* C1 := C1 - W**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; /* L140: */ - } + } /* L150: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**T where C = ( C1 C2 ) */ @@ -665,74 +665,74 @@ f"> */ /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); /* L160: */ - } + } /* W := W * V1**T */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) - 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); - if (*n > *k) { + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork, (ftnlen) + 5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*n > *k) { /* W := W + C2 * V2**T */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & - c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b14, &work[work_offset], - ldwork, (ftnlen)12, (ftnlen)9); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & + c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * + v_dim1 + 1], ldv, &c_b14, &work[work_offset], + ldwork, (ftnlen)12, (ftnlen)9); + } /* W := W * T or W * T**T */ - dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V */ - if (*n > *k) { + if (*n > *k) { /* C2 := C2 - W * V2 */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 - + 1], ldc, (ftnlen)12, (ftnlen)12); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[(*k + 1) * + v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + + 1], ldc, (ftnlen)12, (ftnlen)12); + } /* W := W * V1 */ - dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; /* L170: */ - } + } /* L180: */ - } + } - } + } - } else { + } else { /* Let V = ( V1 V2 ) (V2: last K columns) */ /* where V2 is unit lower triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**T * C where C = ( C1 ) */ /* ( C2 ) */ @@ -741,67 +741,67 @@ f"> */ /* W := C2**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); /* L190: */ - } + } /* W := W * V2**T */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & - v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] - , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); - if (*m > *k) { + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, & + v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*m > *k) { /* W := W + C1**T * V1**T */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork, (ftnlen)9, (ftnlen)9); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork, (ftnlen)9, (ftnlen)9); + } /* W := W * T**T or W * T */ - dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V**T * W**T */ - if (*m > *k) { + if (*m > *k) { /* C1 := C1 - V1**T * W**T */ - i__1 = *m - *k; - dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[ - v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc, (ftnlen)9, (ftnlen)9); - } + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[ + v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc, (ftnlen)9, (ftnlen)9); + } /* W := W * V2 */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, - &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 12, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 12, (ftnlen)4); /* C2 := C2 - W**T */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; /* L200: */ - } + } /* L210: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H' where C = ( C1 C2 ) */ @@ -809,70 +809,70 @@ f"> */ /* W := C2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ - j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); /* L220: */ - } + } /* W := W * V2**T */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & - v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] - , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); - if (*n > *k) { + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, & + v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*n > *k) { /* W := W + C1 * V1**T */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork, (ftnlen)12, (ftnlen)9); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork, (ftnlen)12, (ftnlen)9); + } /* W := W * T or W * T**T */ - dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V */ - if (*n > *k) { + if (*n > *k) { /* C1 := C1 - W * V1 */ - i__1 = *n - *k; - dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, ( - ftnlen)12); - } + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, ( + ftnlen)12); + } /* W := W * V2 */ - dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, - &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 12, (ftnlen)4); + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 12, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; /* L230: */ - } + } /* L240: */ - } + } - } + } - } + } } return 0; @@ -882,5 +882,5 @@ f"> */ } /* dlarfb_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlarfg.cpp b/lib/linalg/dlarfg.cpp index cb544ccf18..6693e1edb6 100644 --- a/lib/linalg/dlarfg.cpp +++ b/lib/linalg/dlarfg.cpp @@ -1,13 +1,13 @@ /* fortran/dlarfg.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -122,8 +122,8 @@ f"> */ /* > \ingroup doubleOTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau) +/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, + integer *incx, doublereal *tau) { /* System generated locals */ integer i__1; @@ -136,11 +136,11 @@ f"> */ integer j, knt; doublereal beta; extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal xnorm; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); doublereal safmin, rsafmn; @@ -172,8 +172,8 @@ f"> */ /* Function Body */ if (*n <= 1) { - *tau = 0.; - return 0; + *tau = 0.; + return 0; } i__1 = *n - 1; @@ -183,50 +183,50 @@ f"> */ /* H = I */ - *tau = 0.; + *tau = 0.; } else { /* general case */ - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); - knt = 0; - if (abs(beta) < safmin) { + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); + knt = 0; + if (abs(beta) < safmin) { /* XNORM, BETA may be inaccurate; scale X and recompute them */ - rsafmn = 1. / safmin; + rsafmn = 1. / safmin; L10: - ++knt; - i__1 = *n - 1; - dscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (abs(beta) < safmin && knt < 20) { - goto L10; - } + ++knt; + i__1 = *n - 1; + dscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } /* New BETA is at most 1, at least SAFMIN */ - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - } - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - d__1 = 1. / (*alpha - beta); - dscal_(&i__1, &d__1, &x[1], incx); + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + } + *tau = (beta - *alpha) / beta; + i__1 = *n - 1; + d__1 = 1. / (*alpha - beta); + dscal_(&i__1, &d__1, &x[1], incx); /* If ALPHA is subnormal, it may lose relative accuracy */ - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; /* L20: */ - } - *alpha = beta; + } + *alpha = beta; } return 0; @@ -236,5 +236,5 @@ L10: } /* dlarfg_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlarft.cpp b/lib/linalg/dlarft.cpp index 220c9f0082..bd0874fa3c 100644 --- a/lib/linalg/dlarft.cpp +++ b/lib/linalg/dlarft.cpp @@ -1,13 +1,13 @@ /* static/dlarft.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -185,8 +185,8 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer * - k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt, ftnlen direct_len, ftnlen storev_len) + k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, + integer *ldt, ftnlen direct_len, ftnlen storev_len) { /* System generated locals */ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; @@ -195,13 +195,13 @@ f"> */ /* Local variables */ integer i__, j, prevlastv; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen); integer lastv; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen); + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen); /* -- LAPACK auxiliary routine -- */ @@ -238,173 +238,173 @@ f"> */ /* Function Body */ if (*n == 0) { - return 0; + return 0; } if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(i__,prevlastv); - if (tau[i__] == 0.) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(i__,prevlastv); + if (tau[i__] == 0.) { /* H(i) = I */ - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.; - } - } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.; + } + } else { /* general case */ - if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { /* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - goto L219; - } - } + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + goto L219; + } + } L219: - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; - } - j = min(lastv,prevlastv); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; + } + j = min(lastv,prevlastv); /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */ - i__2 = j - i__; - i__3 = i__ - 1; - d__1 = -tau[i__]; - dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + - v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & - c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9); - } else { + i__2 = j - i__; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & + c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9); + } else { /* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - goto L235; - } - } + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + goto L235; + } + } L235: - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; - } - j = min(lastv,prevlastv); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } + j = min(lastv,prevlastv); /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */ - i__2 = i__ - 1; - i__3 = j - i__; - d__1 = -tau[i__]; - dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * - v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) - 12); - } + i__2 = i__ - 1; + i__3 = j - i__; + d__1 = -tau[i__]; + dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * + v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], + ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) + 12); + } /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - i__2 = i__ - 1; - dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) - 5, (ftnlen)12, (ftnlen)8); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - } + i__2 = i__ - 1; + dtrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[ + t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) + 5, (ftnlen)12, (ftnlen)8); + t[i__ + i__ * t_dim1] = tau[i__]; + if (i__ > 1) { + prevlastv = max(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + } } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.) { /* H(i) = I */ - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.; - } - } else { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.; + } + } else { /* general case */ - if (i__ < *k) { - if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (i__ < *k) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { /* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - goto L280; - } - } + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + goto L280; + } + } L280: - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ - + j * v_dim1]; - } - j = max(lastv,prevlastv); + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + + j * v_dim1]; + } + j = max(lastv,prevlastv); /* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */ - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - d__1 = -tau[i__]; - dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], & - c__1, (ftnlen)9); - } else { + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + d__1 = -tau[i__]; + dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__ + + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & + c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], & + c__1, (ftnlen)9); + } else { /* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - goto L296; - } - } + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + goto L296; + } + } L296: - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k - + i__) * v_dim1]; - } - j = max(lastv,prevlastv); + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + + i__) * v_dim1]; + } + j = max(lastv,prevlastv); /* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */ - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - d__1 = -tau[i__]; - dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1, - (ftnlen)12); - } + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + d__1 = -tau[i__]; + dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ + + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], + ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1, + (ftnlen)12); + } /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - i__1 = *k - i__; - dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; - } - } + i__1 = *k - i__; + dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__ + + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8) + ; + if (i__ > 1) { + prevlastv = min(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } + } } return 0; @@ -413,5 +413,5 @@ L296: } /* dlarft_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlartg.cpp b/lib/linalg/dlartg.cpp index 118d7865f6..3f5832318e 100644 --- a/lib/linalg/dlartg.cpp +++ b/lib/linalg/dlartg.cpp @@ -1,13 +1,13 @@ /* fortran/dlartg.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -115,8 +115,8 @@ f"> */ /* > \ingroup OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, - doublereal *sn, doublereal *r__) +/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, + doublereal *sn, doublereal *r__) { /* System generated locals */ integer i__1; @@ -171,81 +171,81 @@ f"> */ /* FIRST = .FALSE. */ /* END IF */ if (*g == 0.) { - *cs = 1.; - *sn = 0.; - *r__ = *f; + *cs = 1.; + *sn = 0.; + *r__ = *f; } else if (*f == 0.) { - *cs = 0.; - *sn = 1.; - *r__ = *g; + *cs = 0.; + *sn = 1.; + *r__ = *g; } else { - f1 = *f; - g1 = *g; + f1 = *f; + g1 = *g; /* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale >= safmx2) { - count = 0; + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale >= safmx2) { + count = 0; L10: - ++count; - f1 *= safmn2; - g1 *= safmn2; + ++count; + f1 *= safmn2; + g1 *= safmn2; /* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale >= safmx2) { - goto L10; - } + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale >= safmx2) { + goto L10; + } /* Computing 2nd power */ - d__1 = f1; + d__1 = f1; /* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmx2; + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; /* L20: */ - } - } else if (scale <= safmn2) { - count = 0; + } + } else if (scale <= safmn2) { + count = 0; L30: - ++count; - f1 *= safmx2; - g1 *= safmx2; + ++count; + f1 *= safmx2; + g1 *= safmx2; /* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale <= safmn2) { - goto L30; - } + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale <= safmn2) { + goto L30; + } /* Computing 2nd power */ - d__1 = f1; + d__1 = f1; /* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmn2; + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; /* L40: */ - } - } else { + } + } else { /* Computing 2nd power */ - d__1 = f1; + d__1 = f1; /* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - } - if (abs(*f) > abs(*g) && *cs < 0.) { - *cs = -(*cs); - *sn = -(*sn); - *r__ = -(*r__); - } + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (abs(*f) > abs(*g) && *cs < 0.) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } } return 0; @@ -254,5 +254,5 @@ L30: } /* dlartg_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlas2.cpp b/lib/linalg/dlas2.cpp index e3a53a9bac..c590ed5819 100644 --- a/lib/linalg/dlas2.cpp +++ b/lib/linalg/dlas2.cpp @@ -1,13 +1,13 @@ /* fortran/dlas2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -123,8 +123,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax) +/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, + doublereal *ssmin, doublereal *ssmax) { /* System generated locals */ doublereal d__1, d__2; @@ -159,47 +159,47 @@ extern "C" { fhmn = min(fa,ha); fhmx = max(fa,ha); if (fhmn == 0.) { - *ssmin = 0.; - if (fhmx == 0.) { - *ssmax = ga; - } else { + *ssmin = 0.; + if (fhmx == 0.) { + *ssmax = ga; + } else { /* Computing 2nd power */ - d__1 = min(fhmx,ga) / max(fhmx,ga); - *ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); - } + d__1 = min(fhmx,ga) / max(fhmx,ga); + *ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); + } } else { - if (ga < fhmx) { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; + if (ga < fhmx) { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; /* Computing 2nd power */ - d__1 = ga / fhmx; - au = d__1 * d__1; - c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); - *ssmin = fhmn * c__; - *ssmax = fhmx / c__; - } else { - au = fhmx / ga; - if (au == 0.) { + d__1 = ga / fhmx; + au = d__1 * d__1; + c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); + *ssmin = fhmn * c__; + *ssmax = fhmx / c__; + } else { + au = fhmx / ga; + if (au == 0.) { /* Avoid possible harmful underflow if exponent range */ /* asymmetric (true SSMIN may not underflow even if */ /* AU underflows) */ - *ssmin = fhmn * fhmx / ga; - *ssmax = ga; - } else { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; + *ssmin = fhmn * fhmx / ga; + *ssmax = ga; + } else { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; /* Computing 2nd power */ - d__1 = as * au; + d__1 = as * au; /* Computing 2nd power */ - d__2 = at * au; - c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); - *ssmin = fhmn * c__ * au; - *ssmin += *ssmin; - *ssmax = ga / (c__ + c__); - } - } + d__2 = at * au; + c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); + *ssmin = fhmn * c__ * au; + *ssmin += *ssmin; + *ssmax = ga / (c__ + c__); + } + } } return 0; @@ -208,5 +208,5 @@ extern "C" { } /* dlas2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlascl.cpp b/lib/linalg/dlascl.cpp index 932e1c63cb..7596a5c109 100644 --- a/lib/linalg/dlascl.cpp +++ b/lib/linalg/dlascl.cpp @@ -1,13 +1,13 @@ /* fortran/dlascl.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -159,9 +159,9 @@ f"> */ /* > \ingroup OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublereal *a, integer *lda, integer *info, ftnlen type_len) +/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, + doublereal *cfrom, doublereal *cto, integer *m, integer *n, + doublereal *a, integer *lda, integer *info, ftnlen type_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -215,63 +215,63 @@ f"> */ *info = 0; if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) { - itype = 0; + itype = 0; } else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) { - itype = 1; + itype = 1; } else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) { - itype = 2; + itype = 2; } else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) { - itype = 3; + itype = 3; } else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) { - itype = 4; + itype = 4; } else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) { - itype = 5; + itype = 5; } else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) { - itype = 6; + itype = 6; } else { - itype = -1; + itype = -1; } if (itype == -1) { - *info = -1; + *info = -1; } else if (*cfrom == 0. || disnan_(cfrom)) { - *info = -4; + *info = -4; } else if (disnan_(cto)) { - *info = -5; + *info = -5; } else if (*m < 0) { - *info = -6; + *info = -6; } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { - *info = -7; + *info = -7; } else if (itype <= 3 && *lda < max(1,*m)) { - *info = -9; + *info = -9; } else if (itype >= 4) { /* Computing MAX */ - i__1 = *m - 1; - if (*kl < 0 || *kl > max(i__1,0)) { - *info = -2; - } else /* if(complicated condition) */ { + i__1 = *m - 1; + if (*kl < 0 || *kl > max(i__1,0)) { + *info = -2; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = *n - 1; - if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && - *kl != *ku) { - *info = -3; - } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * - ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { - *info = -9; - } - } + i__1 = *n - 1; + if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASCL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASCL", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0 || *m == 0) { - return 0; + return 0; } /* Get machine parameters */ @@ -287,154 +287,154 @@ L10: if (cfrom1 == cfromc) { /* CFROMC is an inf. Multiply by a correctly signed zero for */ /* finite CTOC, or a NaN if CTOC is infinite. */ - mul = ctoc / cfromc; - done = TRUE_; - cto1 = ctoc; + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; } else { - cto1 = ctoc / bignum; - if (cto1 == ctoc) { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { /* CTOC is either 0 or an inf. In both cases, CTOC itself */ /* serves as the correct multiplication factor. */ - mul = ctoc; - done = TRUE_; - cfromc = 1.; - } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { - mul = smlnum; - done = FALSE_; - cfromc = cfrom1; - } else if (abs(cto1) > abs(cfromc)) { - mul = bignum; - done = FALSE_; - ctoc = cto1; - } else { - mul = ctoc / cfromc; - done = TRUE_; - if (mul == 1.) { - return 0; - } - } + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + if (mul == 1.) { + return 0; + } + } } if (itype == 0) { /* Full matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L20: */ - } + } /* L30: */ - } + } } else if (itype == 1) { /* Lower triangular matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L40: */ - } + } /* L50: */ - } + } } else if (itype == 2) { /* Upper triangular matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L60: */ - } + } /* L70: */ - } + } } else if (itype == 3) { /* Upper Hessenberg matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MIN */ - i__3 = j + 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__3 = j + 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L80: */ - } + } /* L90: */ - } + } } else if (itype == 4) { /* Lower half of a symmetric band matrix */ - k3 = *kl + 1; - k4 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MIN */ - i__3 = k3, i__4 = k4 - j; - i__2 = min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__3 = k3, i__4 = k4 - j; + i__2 = min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L100: */ - } + } /* L110: */ - } + } } else if (itype == 5) { /* Upper half of a symmetric band matrix */ - k1 = *ku + 2; - k3 = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MAX */ - i__2 = k1 - j; - i__3 = k3; - for (i__ = max(i__2,1); i__ <= i__3; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__2 = k1 - j; + i__3 = k3; + for (i__ = max(i__2,1); i__ <= i__3; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L120: */ - } + } /* L130: */ - } + } } else if (itype == 6) { /* Band matrix */ - k1 = *kl + *ku + 2; - k2 = *kl + 1; - k3 = (*kl << 1) + *ku + 1; - k4 = *kl + *ku + 1 + *m; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MAX */ - i__3 = k1 - j; + i__3 = k1 - j; /* Computing MIN */ - i__4 = k3, i__5 = k4 - j; - i__2 = min(i__4,i__5); - for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; + i__4 = k3, i__5 = k4 - j; + i__2 = min(i__4,i__5); + for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; /* L140: */ - } + } /* L150: */ - } + } } if (! done) { - goto L10; + goto L10; } return 0; @@ -444,5 +444,5 @@ L10: } /* dlascl_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasd4.cpp b/lib/linalg/dlasd4.cpp index b0d8d1f7fe..e7922d1199 100644 --- a/lib/linalg/dlasd4.cpp +++ b/lib/linalg/dlasd4.cpp @@ -1,13 +1,13 @@ /* fortran/dlasd4.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -170,9 +170,9 @@ f"> */ /* > at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal * - sigma, doublereal *work, integer *info) +/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__, + doublereal *z__, doublereal *delta, doublereal *rho, doublereal * + sigma, doublereal *work, integer *info) { /* System generated locals */ integer i__1; @@ -197,10 +197,10 @@ f"> */ doublereal dtisq; logical swtch; doublereal dtnsq; - extern /* Subroutine */ int dlaed6_(integer *, logical *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *) - , dlasd5_(integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dlaed6_(integer *, logical *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + , dlasd5_(integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); doublereal delsq2, dtnsq1; logical swtch3; extern doublereal dlamch_(char *, ftnlen); @@ -251,14 +251,14 @@ f"> */ /* Presumably, I=1 upon entry */ - *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); - delta[1] = 1.; - work[1] = 1.; - return 0; + *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); + delta[1] = 1.; + work[1] = 1.; + return 0; } if (*n == 2) { - dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); - return 0; + dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); + return 0; } /* Compute machine epsilon */ @@ -273,145 +273,145 @@ f"> */ /* Initialize some basic variables */ - ii = *n - 1; - niter = 1; + ii = *n - 1; + niter = 1; /* Calculate initial guess */ - temp = *rho / 2.; + temp = *rho / 2.; /* If ||Z||_2 is not one, then TEMP should be set to */ /* RHO * ||Z||_2^2 / TWO */ - temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*n] + temp1; - delta[j] = d__[j] - d__[*n] - temp1; + temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*n] + temp1; + delta[j] = d__[j] - d__[*n] - temp1; /* L10: */ - } + } - psi = 0.; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (delta[j] * work[j]); + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (delta[j] * work[j]); /* L20: */ - } + } - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* - n] / (delta[*n] * work[*n]); + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* + n] / (delta[*n] * work[*n]); - if (w <= 0.) { - temp1 = sqrt(d__[*n] * d__[*n] + *rho); - temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* - n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * - z__[*n] / *rho; + if (w <= 0.) { + temp1 = sqrt(d__[*n] * d__[*n] + *rho); + temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* + n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * + z__[*n] / *rho; /* The following TAU2 is to approximate */ /* SIGMA_n^2 - D( N )*D( N ) */ - if (c__ <= temp) { - tau = *rho; - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* - n]; - b = z__[*n] * z__[*n] * delsq; - if (a < 0.) { - tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); - } + if (c__ <= temp) { + tau = *rho; + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* + n]; + b = z__[*n] * z__[*n] * delsq; + if (a < 0.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + } /* It can be proved that */ /* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO */ - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * delsq; + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * delsq; /* The following TAU2 is to approximate */ /* SIGMA_n^2 - D( N )*D( N ) */ - if (a < 0.) { - tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + if (a < 0.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); /* It can be proved that */ /* D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 */ - } + } /* The following TAU is to approximate SIGMA_n - D( N ) */ /* TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) */ - *sigma = d__[*n] + tau; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*n] - tau; - work[j] = d__[j] + d__[*n] + tau; + *sigma = d__[*n] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*n] - tau; + work[j] = d__[j] + d__[*n] + tau; /* L30: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (delta[j] * work[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (delta[j] * work[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L40: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - temp = z__[*n] / (delta[*n] * work[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + temp = z__[*n] / (delta[*n] * work[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; /* $ + ABS( TAU2 )*( DPSI+DPHI ) */ - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* Test for convergence */ - if (abs(w) <= eps * erretm) { - goto L240; - } + if (abs(w) <= eps * erretm) { + goto L240; + } /* Calculate the new step */ - ++niter; - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); - b = dtnsq * dtnsq1 * w; - if (c__ < 0.) { - c__ = abs(c__); - } - if (c__ == 0.) { - eta = *rho - *sigma * *sigma; - } else if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } + ++niter; + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); + b = dtnsq * dtnsq1 * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { + eta = *rho - *sigma * *sigma; + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -419,77 +419,77 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp > *rho) { - eta = *rho + dtnsq; - } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp > *rho) { + eta = *rho + dtnsq; + } - eta /= *sigma + sqrt(eta + *sigma * *sigma); - tau += eta; - *sigma += eta; + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; /* L50: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L60: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - tau2 = work[*n] * delta[*n]; - temp = z__[*n] / tau2; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; /* $ + ABS( TAU2 )*( DPSI+DPHI ) */ - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* Main loop to update the values of the array DELTA */ - iter = niter + 1; + iter = niter + 1; - for (niter = iter; niter <= 400; ++niter) { + for (niter = iter; niter <= 400; ++niter) { /* Test for convergence */ - if (abs(w) <= eps * erretm) { - goto L240; - } + if (abs(w) <= eps * erretm) { + goto L240; + } /* Calculate the new step */ - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); - b = dtnsq1 * dtnsq * w; - if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); + b = dtnsq1 * dtnsq * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -497,57 +497,57 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp <= 0.) { - eta /= 2.; - } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp <= 0.) { + eta /= 2.; + } - eta /= *sigma + sqrt(eta + *sigma * *sigma); - tau += eta; - *sigma += eta; + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; /* L70: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L80: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - tau2 = work[*n] * delta[*n]; - temp = z__[*n] / tau2; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; /* $ + ABS( TAU2 )*( DPSI+DPHI ) */ - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* L90: */ - } + } /* Return with INFO = 1, NITER = MAXIT and not converged */ - *info = 1; - goto L240; + *info = 1; + goto L240; /* End for the case I = N */ @@ -555,288 +555,288 @@ f"> */ /* The case for I < N */ - niter = 1; - ip1 = *i__ + 1; + niter = 1; + ip1 = *i__ + 1; /* Calculate initial guess */ - delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); - delsq2 = delsq / 2.; - sq2 = sqrt((d__[*i__] * d__[*i__] + d__[ip1] * d__[ip1]) / 2.); - temp = delsq2 / (d__[*i__] + sq2); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + temp; - delta[j] = d__[j] - d__[*i__] - temp; + delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); + delsq2 = delsq / 2.; + sq2 = sqrt((d__[*i__] * d__[*i__] + d__[ip1] * d__[ip1]) / 2.); + temp = delsq2 / (d__[*i__] + sq2); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*i__] + temp; + delta[j] = d__[j] - d__[*i__] - temp; /* L100: */ - } + } - psi = 0.; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (work[j] * delta[j]); + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (work[j] * delta[j]); /* L110: */ - } + } - phi = 0.; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / (work[j] * delta[j]); + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / (work[j] * delta[j]); /* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ - ip1] * z__[ip1] / (work[ip1] * delta[ip1]); + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ + ip1] * z__[ip1] / (work[ip1] * delta[ip1]); - geomavg = FALSE_; - if (w > 0.) { + geomavg = FALSE_; + if (w > 0.) { /* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ /* We choose d(i) as origin. */ - orgati = TRUE_; - ii = *i__; - sglb = 0.; - sgub = delsq2 / (d__[*i__] + sq2); - a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * delsq; - if (a > 0.) { - tau2 = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } else { - tau2 = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / - (c__ * 2.); - } + orgati = TRUE_; + ii = *i__; + sglb = 0.; + sgub = delsq2 / (d__[*i__] + sq2); + a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * delsq; + if (a > 0.) { + tau2 = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau2 = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } /* TAU2 now is an estimation of SIGMA^2 - D( I )^2. The */ /* following, however, is the corresponding estimation of */ /* SIGMA - D( I ). */ - tau = tau2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau2)); - temp = sqrt(eps); - if (d__[*i__] <= temp * d__[ip1] && (d__1 = z__[*i__], abs(d__1)) - <= temp && d__[*i__] > 0.) { + tau = tau2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau2)); + temp = sqrt(eps); + if (d__[*i__] <= temp * d__[ip1] && (d__1 = z__[*i__], abs(d__1)) + <= temp && d__[*i__] > 0.) { /* Computing MIN */ - d__1 = d__[*i__] * 10.; - tau = min(d__1,sgub); - geomavg = TRUE_; - } - } else { + d__1 = d__[*i__] * 10.; + tau = min(d__1,sgub); + geomavg = TRUE_; + } + } else { /* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ /* We choose d(i+1) as origin. */ - orgati = FALSE_; - ii = ip1; - sglb = -delsq2 / (d__[ii] + sq2); - sgub = 0.; - a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * delsq; - if (a < 0.) { - tau2 = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( - d__1)))); - } else { - tau2 = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / - (c__ * 2.); - } + orgati = FALSE_; + ii = ip1; + sglb = -delsq2 / (d__[ii] + sq2); + sgub = 0.; + a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * delsq; + if (a < 0.) { + tau2 = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau2 = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } /* TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The */ /* following, however, is the corresponding estimation of */ /* SIGMA - D( IP1 ). */ - tau = tau2 / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau2, - abs(d__1)))); - } + tau = tau2 / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau2, + abs(d__1)))); + } - *sigma = d__[ii] + tau; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[ii] + tau; - delta[j] = d__[j] - d__[ii] - tau; + *sigma = d__[ii] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[ii] + tau; + delta[j] = d__[j] - d__[ii] - tau; /* L130: */ - } - iim1 = ii - 1; - iip1 = ii + 1; + } + iim1 = ii - 1; + iip1 = ii + 1; /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L150: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L160: */ - } + } - w = rhoinv + phi + psi; + w = rhoinv + phi + psi; /* W is the value of the secular function with */ /* its ii-th element removed. */ - swtch3 = FALSE_; - if (orgati) { - if (w < 0.) { - swtch3 = TRUE_; - } - } else { - if (w > 0.) { - swtch3 = TRUE_; - } - } - if (ii == 1 || ii == *n) { - swtch3 = FALSE_; - } + swtch3 = FALSE_; + if (orgati) { + if (w < 0.) { + swtch3 = TRUE_; + } + } else { + if (w > 0.) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w += temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; /* $ + ABS( TAU2 )*DW */ /* Test for convergence */ - if (abs(w) <= eps * erretm) { - goto L240; - } + if (abs(w) <= eps * erretm) { + goto L240; + } - if (w <= 0.) { - sglb = max(sglb,tau); - } else { - sgub = min(sgub,tau); - } + if (w <= 0.) { + sglb = max(sglb,tau); + } else { + sgub = min(sgub,tau); + } /* Calculate the new step */ - ++niter; - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (orgati) { + ++niter; + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + - dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + - dphi); - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + } else { /* Interpolation using THREE most relevant poles */ - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * - (d__[iim1] + d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * - (d__[iim1] + d__[iip1]) * temp1; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * + (d__[iim1] + d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * + (d__[iim1] + d__[iip1]) * temp1; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { + if (*info != 0) { /* If INFO is not 0, i.e., DLAED6 failed, switch back */ /* to 2 pole interpolation. */ - swtch3 = FALSE_; - *info = 0; - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (orgati) { + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * ( - dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + - dphi); - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) - / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } - } + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * ( + dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -844,255 +844,255 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta >= 0.) { - eta = -w / dw; - } + if (w * eta >= 0.) { + eta = -w / dw; + } - eta /= *sigma + sqrt(*sigma * *sigma + eta); - temp = tau + eta; - if (temp > sgub || temp < sglb) { - if (w < 0.) { - eta = (sgub - tau) / 2.; - } else { - eta = (sglb - tau) / 2.; - } - if (geomavg) { - if (w < 0.) { - if (tau > 0.) { - eta = sqrt(sgub * tau) - tau; - } - } else { - if (sglb > 0.) { - eta = sqrt(sglb * tau) - tau; - } - } - } - } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } - prew = w; + prew = w; - tau += eta; - *sigma += eta; + tau += eta; + *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; /* L170: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L180: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L190: */ - } + } - tau2 = work[ii] * delta[ii]; - temp = z__[ii] / tau2; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; /* $ + ABS( TAU2 )*DW */ - swtch = FALSE_; - if (orgati) { - if (-w > abs(prew) / 10.) { - swtch = TRUE_; - } - } else { - if (w > abs(prew) / 10.) { - swtch = TRUE_; - } - } + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.) { + swtch = TRUE_; + } + } /* Main loop to update the values of the array DELTA and WORK */ - iter = niter + 1; + iter = niter + 1; - for (niter = iter; niter <= 400; ++niter) { + for (niter = iter; niter <= 400; ++niter) { /* Test for convergence */ - if (abs(w) <= eps * erretm) { + if (abs(w) <= eps * erretm) { /* $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN */ - goto L240; - } + goto L240; + } - if (w <= 0.) { - sglb = max(sglb,tau); - } else { - sgub = min(sgub,tau); - } + if (w <= 0.) { + sglb = max(sglb,tau); + } else { + sgub = min(sgub,tau); + } /* Calculate the new step */ - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (! swtch) { - if (orgati) { + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (! swtch) { + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - } else { - temp = z__[ii] / (work[ii] * delta[ii]); - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - dtisq * dpsi - dtipsq * dphi; - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( - dpsi + dphi); - } - } else { - a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) - / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( + dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } else { /* Interpolation using THREE most relevant poles */ - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - dtiim * dpsi - dtiip * dphi; - zz[0] = dtiim * dtiim * dpsi; - zz[2] = dtiip * dtiip * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiip * (dpsi + dphi) - temp2; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiim * (dpsi + dphi) - temp2; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - } - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - dtiim * dpsi - dtiip * dphi; + zz[0] = dtiim * dtiim * dpsi; + zz[2] = dtiip * dtiip * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiip * (dpsi + dphi) - temp2; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiim * (dpsi + dphi) - temp2; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + } + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { + if (*info != 0) { /* If INFO is not 0, i.e., DLAED6 failed, switch */ /* back to two pole interpolation */ - swtch3 = FALSE_; - *info = 0; - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (! swtch) { - if (orgati) { + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (! swtch) { + if (orgati) { /* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { /* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - } else { - temp = z__[ii] / (work[ii] * delta[ii]); - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - dtisq * dpsi - dtipsq * dphi; - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * - dtipsq * (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * - (dpsi + dphi); - } - } else { - a = dtisq * dtisq * dpsi + dtipsq * dtipsq * - dphi; - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))) / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } - } + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * + dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * + (dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * + dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } + } /* Note, eta should be positive if w is negative, and */ /* eta should be negative otherwise. However, */ @@ -1100,89 +1100,89 @@ f"> */ /* we simply use one Newton step instead. This way */ /* will guarantee eta*w < 0. */ - if (w * eta >= 0.) { - eta = -w / dw; - } + if (w * eta >= 0.) { + eta = -w / dw; + } - eta /= *sigma + sqrt(*sigma * *sigma + eta); - temp = tau + eta; - if (temp > sgub || temp < sglb) { - if (w < 0.) { - eta = (sgub - tau) / 2.; - } else { - eta = (sglb - tau) / 2.; - } - if (geomavg) { - if (w < 0.) { - if (tau > 0.) { - eta = sqrt(sgub * tau) - tau; - } - } else { - if (sglb > 0.) { - eta = sqrt(sglb * tau) - tau; - } - } - } - } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } - prew = w; + prew = w; - tau += eta; - *sigma += eta; + tau += eta; + *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; /* L200: */ - } + } /* Evaluate PSI and the derivative DPSI */ - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; /* L210: */ - } - erretm = abs(erretm); + } + erretm = abs(erretm); /* Evaluate PHI and the derivative DPHI */ - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; /* L220: */ - } + } - tau2 = work[ii] * delta[ii]; - temp = z__[ii] / tau2; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; /* $ + ABS( TAU2 )*DW */ - if (w * prew > 0. && abs(w) > abs(prew) / 10.) { - swtch = ! swtch; - } + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = ! swtch; + } /* L230: */ - } + } /* Return with INFO = 1, NITER = MAXIT and not converged */ - *info = 1; + *info = 1; } @@ -1194,5 +1194,5 @@ L240: } /* dlasd4_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasd5.cpp b/lib/linalg/dlasd5.cpp index a789475cad..a56f570c0b 100644 --- a/lib/linalg/dlasd5.cpp +++ b/lib/linalg/dlasd5.cpp @@ -1,13 +1,13 @@ /* fortran/dlasd5.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -133,9 +133,9 @@ f"> */ /* > at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal * - work) +/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, + doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal * + work) { /* System generated locals */ doublereal d__1; @@ -176,51 +176,51 @@ f"> */ del = d__[2] - d__[1]; delsq = del * (d__[2] + d__[1]); if (*i__ == 1) { - w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] * - z__[1] / (d__[1] * 3. + d__[2])) / del + 1.; - if (w > 0.) { - b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[1] * z__[1] * delsq; + w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] * + z__[1] / (d__[1] * 3. + d__[2])) / del + 1.; + if (w > 0.) { + b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * delsq; /* B > ZERO, always */ /* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */ - tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); /* The following TAU is DSIGMA - D( 1 ) */ - tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); - *dsigma = d__[1] + tau; - delta[1] = -tau; - delta[2] = del - tau; - work[1] = d__[1] * 2. + tau; - work[2] = d__[1] + tau + d__[2]; + tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); + *dsigma = d__[1] + tau; + delta[1] = -tau; + delta[2] = del - tau; + work[1] = d__[1] * 2. + tau; + work[2] = d__[1] + tau + d__[2]; /* DELTA( 1 ) = -Z( 1 ) / TAU */ /* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */ - } else { - b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * delsq; + } else { + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; /* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ - if (b > 0.) { - tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); - } else { - tau = (b - sqrt(b * b + c__ * 4.)) / 2.; - } + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } /* The following TAU is DSIGMA - D( 2 ) */ - tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); - *dsigma = d__[2] + tau; - delta[1] = -(del + tau); - delta[2] = -tau; - work[1] = d__[1] + tau + d__[2]; - work[2] = d__[2] * 2. + tau; + tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; /* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ /* DELTA( 2 ) = -Z( 2 ) / TAU */ - } + } /* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ /* DELTA( 1 ) = DELTA( 1 ) / TEMP */ /* DELTA( 2 ) = DELTA( 2 ) / TEMP */ @@ -228,25 +228,25 @@ f"> */ /* Now I=2 */ - b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * delsq; + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; /* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ - if (b > 0.) { - tau = (b + sqrt(b * b + c__ * 4.)) / 2.; - } else { - tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); - } + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } /* The following TAU is DSIGMA - D( 2 ) */ - tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); - *dsigma = d__[2] + tau; - delta[1] = -(del + tau); - delta[2] = -tau; - work[1] = d__[1] + tau + d__[2]; - work[2] = d__[2] * 2. + tau; + tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; /* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ /* DELTA( 2 ) = -Z( 2 ) / TAU */ /* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ @@ -260,5 +260,5 @@ f"> */ } /* dlasd5_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasd6.cpp b/lib/linalg/dlasd6.cpp index d3b6cddd86..48c7d8dd4f 100644 --- a/lib/linalg/dlasd6.cpp +++ b/lib/linalg/dlasd6.cpp @@ -1,13 +1,13 @@ /* fortran/dlasd6.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -334,34 +334,34 @@ f"> */ /* > California at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl, - doublereal *alpha, doublereal *beta, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, - integer *ldgnum, doublereal *poles, doublereal *difl, doublereal * - difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s, - doublereal *work, integer *iwork, integer *info) +/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, + integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl, + doublereal *alpha, doublereal *beta, integer *idxq, integer *perm, + integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, + integer *ldgnum, doublereal *poles, doublereal *difl, doublereal * + difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s, + doublereal *work, integer *iwork, integer *info) { /* System generated locals */ - integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, - poles_dim1, poles_offset, i__1; + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, i__1; doublereal d__1, d__2; /* Local variables */ integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dlasd7_(integer *, integer *, integer *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - integer *, integer *, integer *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *), dlasd8_( - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - doublereal *, integer *), dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dlamrg_(integer *, integer *, - doublereal *, integer *, integer *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dlasd7_(integer *, integer *, integer *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *), dlasd8_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dlamrg_(integer *, integer *, + doublereal *, integer *, integer *, integer *); integer isigma; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal orgnrm; @@ -417,22 +417,22 @@ f"> */ m = n + *sqre; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*nl < 1) { - *info = -2; + *info = -2; } else if (*nr < 1) { - *info = -3; + *info = -3; } else if (*sqre < 0 || *sqre > 1) { - *info = -4; + *info = -4; } else if (*ldgcol < n) { - *info = -14; + *info = -14; } else if (*ldgnum < n) { - *info = -16; + *info = -16; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASD6", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASD6", &i__1, (ftnlen)6); + return 0; } /* The following values are for bookkeeping purposes only. They are */ @@ -456,46 +456,46 @@ f"> */ d__[*nl + 1] = 0.; i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { - orgnrm = (d__1 = d__[i__], abs(d__1)); - } + if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { + orgnrm = (d__1 = d__[i__], abs(d__1)); + } /* L10: */ } dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, ( - ftnlen)1); + ftnlen)1); *alpha /= orgnrm; *beta /= orgnrm; /* Sort and Deflate singular values. */ dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], & - work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & - iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ - givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, - info); + work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & + iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ + givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, + info); /* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */ - dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], - ldgnum, &work[isigma], &work[iw], info); + dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], + ldgnum, &work[isigma], &work[iw], info); /* Report the possible convergence failure. */ if (*info != 0) { - return 0; + return 0; } /* Save the poles if ICOMPQ = 1. */ if (*icompq == 1) { - dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); - dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); + dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); + dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); } /* Unscale. */ dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, ( - ftnlen)1); + ftnlen)1); /* Prepare the IDXQ sorting permutation. */ @@ -510,5 +510,5 @@ f"> */ } /* dlasd6_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasd7.cpp b/lib/linalg/dlasd7.cpp index 29169c7a84..89a18cc81f 100644 --- a/lib/linalg/dlasd7.cpp +++ b/lib/linalg/dlasd7.cpp @@ -1,13 +1,13 @@ /* fortran/dlasd7.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries +/* > \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. */ /* =========== DOCUMENTATION =========== */ @@ -298,13 +298,13 @@ f"> */ /* > California at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, doublereal *d__, doublereal *z__, - doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, - doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal * - dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, - integer *ldgnum, doublereal *c__, doublereal *s, integer *info) +/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *k, doublereal *d__, doublereal *z__, + doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, + doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal * + dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, + integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, + integer *ldgnum, doublereal *c__, doublereal *s, integer *info) { /* System generated locals */ integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; @@ -316,17 +316,17 @@ f"> */ integer jp; doublereal eps, tau, tol; integer nlp1, nlp2, idxi, idxj; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); integer idxjp; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer jprev; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen); doublereal hlftol; @@ -382,28 +382,28 @@ f"> */ m = n + *sqre; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*nl < 1) { - *info = -2; + *info = -2; } else if (*nr < 1) { - *info = -3; + *info = -3; } else if (*sqre < 0 || *sqre > 1) { - *info = -4; + *info = -4; } else if (*ldgcol < n) { - *info = -22; + *info = -22; } else if (*ldgnum < n) { - *info = -24; + *info = -24; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASD7", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASD7", &i__1, (ftnlen)6); + return 0; } nlp1 = *nl + 1; nlp2 = *nl + 2; if (*icompq == 1) { - *givptr = 0; + *givptr = 0; } /* Generate the first part of the vector Z and move the singular */ @@ -413,11 +413,11 @@ f"> */ vl[nlp1] = 0.; tau = vf[nlp1]; for (i__ = *nl; i__ >= 1; --i__) { - z__[i__ + 1] = *alpha * vl[i__]; - vl[i__] = 0.; - vf[i__ + 1] = vf[i__]; - d__[i__ + 1] = d__[i__]; - idxq[i__ + 1] = idxq[i__] + 1; + z__[i__ + 1] = *alpha * vl[i__]; + vl[i__] = 0.; + vf[i__ + 1] = vf[i__]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; /* L10: */ } vf[1] = tau; @@ -426,8 +426,8 @@ f"> */ i__1 = m; for (i__ = nlp2; i__ <= i__1; ++i__) { - z__[i__] = *beta * vf[i__]; - vf[i__] = 0.; + z__[i__] = *beta * vf[i__]; + vf[i__] = 0.; /* L20: */ } @@ -435,7 +435,7 @@ f"> */ i__1 = n; for (i__ = nlp2; i__ <= i__1; ++i__) { - idxq[i__] += nlp1; + idxq[i__] += nlp1; /* L30: */ } @@ -443,10 +443,10 @@ f"> */ i__1 = n; for (i__ = 2; i__ <= i__1; ++i__) { - dsigma[i__] = d__[idxq[i__]]; - zw[i__] = z__[idxq[i__]]; - vfw[i__] = vf[idxq[i__]]; - vlw[i__] = vl[idxq[i__]]; + dsigma[i__] = d__[idxq[i__]]; + zw[i__] = z__[idxq[i__]]; + vfw[i__] = vf[idxq[i__]]; + vlw[i__] = vl[idxq[i__]]; /* L40: */ } @@ -454,11 +454,11 @@ f"> */ i__1 = n; for (i__ = 2; i__ <= i__1; ++i__) { - idxi = idx[i__] + 1; - d__[i__] = dsigma[idxi]; - z__[i__] = zw[idxi]; - vf[i__] = vfw[idxi]; - vl[i__] = vlw[idxi]; + idxi = idx[i__] + 1; + d__[i__] = dsigma[idxi]; + z__[i__] = zw[idxi]; + vf[i__] = vfw[idxi]; + vl[i__] = vlw[idxi]; /* L50: */ } @@ -495,19 +495,19 @@ f"> */ k2 = n + 1; i__1 = n; for (j = 2; j <= i__1; ++j) { - if ((d__1 = z__[j], abs(d__1)) <= tol) { + if ((d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - idxp[k2] = j; - if (j == n) { - goto L100; - } - } else { - jprev = j; - goto L70; - } + --k2; + idxp[k2] = j; + if (j == n) { + goto L100; + } + } else { + jprev = j; + goto L70; + } /* L60: */ } L70: @@ -515,63 +515,63 @@ L70: L80: ++j; if (j > n) { - goto L90; + goto L90; } if ((d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - idxp[k2] = j; + --k2; + idxp[k2] = j; } else { /* Check if singular values are close enough to allow deflation. */ - if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { + if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { /* Deflation is possible. */ - *s = z__[jprev]; - *c__ = z__[j]; + *s = z__[jprev]; + *c__ = z__[j]; /* Find sqrt(a**2+b**2) without overflow or */ /* destructive underflow. */ - tau = dlapy2_(c__, s); - z__[j] = tau; - z__[jprev] = 0.; - *c__ /= tau; - *s = -(*s) / tau; + tau = dlapy2_(c__, s); + z__[j] = tau; + z__[jprev] = 0.; + *c__ /= tau; + *s = -(*s) / tau; /* Record the appropriate Givens rotation */ - if (*icompq == 1) { - ++(*givptr); - idxjp = idxq[idx[jprev] + 1]; - idxj = idxq[idx[j] + 1]; - if (idxjp <= nlp1) { - --idxjp; - } - if (idxj <= nlp1) { - --idxj; - } - givcol[*givptr + (givcol_dim1 << 1)] = idxjp; - givcol[*givptr + givcol_dim1] = idxj; - givnum[*givptr + (givnum_dim1 << 1)] = *c__; - givnum[*givptr + givnum_dim1] = *s; - } - drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); - drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); - --k2; - idxp[k2] = jprev; - jprev = j; - } else { - ++(*k); - zw[*k] = z__[jprev]; - dsigma[*k] = d__[jprev]; - idxp[*k] = jprev; - jprev = j; - } + if (*icompq == 1) { + ++(*givptr); + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + givcol[*givptr + (givcol_dim1 << 1)] = idxjp; + givcol[*givptr + givcol_dim1] = idxj; + givnum[*givptr + (givnum_dim1 << 1)] = *c__; + givnum[*givptr + givnum_dim1] = *s; + } + drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); + drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } } goto L80; L90: @@ -591,22 +591,22 @@ L100: i__1 = n; for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - dsigma[j] = d__[jp]; - vfw[j] = vf[jp]; - vlw[j] = vl[jp]; + jp = idxp[j]; + dsigma[j] = d__[jp]; + vfw[j] = vf[jp]; + vlw[j] = vl[jp]; /* L110: */ } if (*icompq == 1) { - i__1 = n; - for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - perm[j] = idxq[idx[jp] + 1]; - if (perm[j] <= nlp1) { - --perm[j]; - } + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + perm[j] = idxq[idx[jp] + 1]; + if (perm[j] <= nlp1) { + --perm[j]; + } /* L120: */ - } + } } /* The deflated singular values go back into the last N - K slots of */ @@ -621,26 +621,26 @@ L100: dsigma[1] = 0.; hlftol = tol / 2.; if (abs(dsigma[2]) <= hlftol) { - dsigma[2] = hlftol; + dsigma[2] = hlftol; } if (m > n) { - z__[1] = dlapy2_(&z1, &z__[m]); - if (z__[1] <= tol) { - *c__ = 1.; - *s = 0.; - z__[1] = tol; - } else { - *c__ = z1 / z__[1]; - *s = -z__[m] / z__[1]; - } - drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); - drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); + z__[1] = dlapy2_(&z1, &z__[m]); + if (z__[1] <= tol) { + *c__ = 1.; + *s = 0.; + z__[1] = tol; + } else { + *c__ = z1 / z__[1]; + *s = -z__[m] / z__[1]; + } + drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); + drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); } else { - if (abs(z1) <= tol) { - z__[1] = tol; - } else { - z__[1] = z1; - } + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } } /* Restore Z, VF, and VL. */ @@ -659,5 +659,5 @@ L100: } /* dlasd7_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasd8.cpp b/lib/linalg/dlasd8.cpp index b95d5b11cc..3ec481bb55 100644 --- a/lib/linalg/dlasd8.cpp +++ b/lib/linalg/dlasd8.cpp @@ -1,13 +1,13 @@ /* fortran/dlasd8.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -188,10 +188,10 @@ f"> */ /* > California at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__, - doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl, - doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal * - work, integer *info) +/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__, + doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl, + doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal * + work, integer *info) { /* System generated locals */ integer difr_dim1, difr_offset, i__1, i__2; @@ -204,22 +204,22 @@ f"> */ integer i__, j; doublereal dj, rho; integer iwk1, iwk2, iwk3; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); doublereal temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); integer iwk2i, iwk3i; doublereal diflj, difrj, dsigj; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); extern doublereal dlamc3_(doublereal *, doublereal *); - extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *), dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dlaset_(char *, integer *, integer - *, doublereal *, doublereal *, doublereal *, integer *, ftnlen), - xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *), dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dlaset_(char *, integer *, integer + *, doublereal *, doublereal *, doublereal *, integer *, ftnlen), + xerbla_(char *, integer *, ftnlen); doublereal dsigjp; @@ -264,28 +264,28 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*k < 1) { - *info = -2; + *info = -2; } else if (*lddifr < *k) { - *info = -9; + *info = -9; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASD8", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASD8", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*k == 1) { - d__[1] = abs(z__[1]); - difl[1] = d__[1]; - if (*icompq == 1) { - difl[2] = 1.; - difr[(difr_dim1 << 1) + 1] = 1.; - } - return 0; + d__[1] = abs(z__[1]); + difl[1] = d__[1]; + if (*icompq == 1) { + difl[2] = 1.; + difr[(difr_dim1 << 1) + 1] = 1.; + } + return 0; } /* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ @@ -307,7 +307,7 @@ f"> */ i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; + dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; /* L10: */ } @@ -323,7 +323,7 @@ f"> */ rho = dnrm2_(k, &z__[1], &c__1); dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, ( - ftnlen)1); + ftnlen)1); rho *= rho; /* Initialize WORK(IWK3). */ @@ -335,31 +335,31 @@ f"> */ i__1 = *k; for (j = 1; j <= i__1; ++j) { - dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ - iwk2], info); + dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ + iwk2], info); /* If the root finder fails, report the convergence failure. */ - if (*info != 0) { - return 0; - } - work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; - difl[j] = -work[j]; - difr[j + difr_dim1] = -work[j + 1]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + - i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ - j]); + if (*info != 0) { + return 0; + } + work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; + difl[j] = -work[j]; + difr[j + difr_dim1] = -work[j + 1]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); /* L20: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + - i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ - j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); /* L30: */ - } + } /* L40: */ } @@ -367,8 +367,8 @@ f"> */ i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); - z__[i__] = d_sign(&d__2, &z__[i__]); + d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); + z__[i__] = d_sign(&d__2, &z__[i__]); /* L50: */ } @@ -376,32 +376,32 @@ f"> */ i__1 = *k; for (j = 1; j <= i__1; ++j) { - diflj = difl[j]; - dj = d__[j]; - dsigj = -dsigma[j]; - if (j < *k) { - difrj = -difr[j + difr_dim1]; - dsigjp = -dsigma[j + 1]; - } - work[j] = -z__[j] / diflj / (dsigma[j] + dj); - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / ( - dsigma[i__] + dj); + diflj = difl[j]; + dj = d__[j]; + dsigj = -dsigma[j]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -dsigma[j + 1]; + } + work[j] = -z__[j] / diflj / (dsigma[j] + dj); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / ( + dsigma[i__] + dj); /* L60: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / - (dsigma[i__] + dj); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / + (dsigma[i__] + dj); /* L70: */ - } - temp = dnrm2_(k, &work[1], &c__1); - work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; - work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; - if (*icompq == 1) { - difr[j + (difr_dim1 << 1)] = temp; - } + } + temp = dnrm2_(k, &work[1], &c__1); + work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; + work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; + if (*icompq == 1) { + difr[j + (difr_dim1 << 1)] = temp; + } /* L80: */ } @@ -415,5 +415,5 @@ f"> */ } /* dlasd8_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasda.cpp b/lib/linalg/dlasda.cpp index a63dc14dec..d064a9af51 100644 --- a/lib/linalg/dlasda.cpp +++ b/lib/linalg/dlasda.cpp @@ -1,13 +1,13 @@ /* fortran/dlasda.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -296,47 +296,47 @@ f"> */ /* > California at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer - *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, - doublereal *z__, doublereal *poles, integer *givptr, integer *givcol, - integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__, - doublereal *s, doublereal *work, integer *iwork, integer *info) +/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, + integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer + *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, + doublereal *z__, doublereal *poles, integer *givptr, integer *givcol, + integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__, + doublereal *s, doublereal *work, integer *iwork, integer *info) { /* System generated locals */ - integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, - difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, - poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, - z_dim1, z_offset, i__1, i__2; + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, + difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, + z_dim1, z_offset, i__1, i__2; /* Builtin functions */ integer pow_ii(integer *, integer *); /* Local variables */ integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf, - vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1; + vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1; doublereal beta; integer idxq, nlvl; doublereal alpha; integer inode, ndiml, ndimr, idxqi, itemp; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer sqrei; - extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, integer *, integer *); + extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *); integer nwork1, nwork2; - extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer - *, integer *, integer *, doublereal *, doublereal *, doublereal *, - integer *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, ftnlen), dlasdt_(integer *, integer *, - integer *, integer *, integer *, integer *, integer *), dlaset_( - char *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer + *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, ftnlen), dlasdt_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *), dlaset_( + char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen), xerbla_(char *, integer *, + ftnlen); integer smlszp; @@ -402,22 +402,22 @@ f"> */ *info = 0; if (*icompq < 0 || *icompq > 1) { - *info = -1; + *info = -1; } else if (*smlsiz < 3) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*sqre < 0 || *sqre > 1) { - *info = -4; + *info = -4; } else if (*ldu < *n + *sqre) { - *info = -8; + *info = -8; } else if (*ldgcol < *n) { - *info = -17; + *info = -17; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASDA", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASDA", &i__1, (ftnlen)6); + return 0; } m = *n + *sqre; @@ -425,16 +425,16 @@ f"> */ /* If the input matrix is too small, call DLASDQ to find the SVD. */ if (*n <= *smlsiz) { - if (*icompq == 0) { - dlasdq_((char *)"U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ - vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & - work[1], info, (ftnlen)1); - } else { - dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] - , ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], - info, (ftnlen)1); - } - return 0; + if (*icompq == 0) { + dlasdq_((char *)"U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ + vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & + work[1], info, (ftnlen)1); + } else { + dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] + , ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], + info, (ftnlen)1); + } + return 0; } /* Book-keeping and set up the computation tree. */ @@ -454,8 +454,8 @@ f"> */ nwork1 = vl + m; nwork2 = nwork1 + smlszp * smlszp; - dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); /* for the nodes on bottom level of the tree, solve */ /* their subproblems by DLASDQ. */ @@ -470,84 +470,84 @@ f"> */ /* NLF: starting row of the left subproblem */ /* NRF: starting row of the right subproblem */ - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nlp1 = nl + 1; - nr = iwork[ndimr + i1]; - nlf = ic - nl; - nrf = ic + 1; - idxqi = idxq + nlf - 2; - vfi = vf + nlf - 1; - vli = vl + nlf - 1; - sqrei = 1; - if (*icompq == 0) { - dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp, - (ftnlen)1); - dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & - work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], - &nl, &work[nwork2], info, (ftnlen)1); - itemp = nwork1 + nl * smlszp; - dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); - dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, ( - ftnlen)1); - dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], - ldu, (ftnlen)1); - dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & - vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + - u_dim1], ldu, &work[nwork1], info, (ftnlen)1); - dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); - dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) - ; - } - if (*info != 0) { - return 0; - } - i__2 = nl; - for (j = 1; j <= i__2; ++j) { - iwork[idxqi + j] = j; + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nlp1 = nl + 1; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + idxqi = idxq + nlf - 2; + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + sqrei = 1; + if (*icompq == 0) { + dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp, + (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & + work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], + &nl, &work[nwork2], info, (ftnlen)1); + itemp = nwork1 + nl * smlszp; + dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, ( + ftnlen)1); + dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], + ldu, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & + vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + + u_dim1], ldu, &work[nwork1], info, (ftnlen)1); + dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; /* L10: */ - } - if (i__ == nd && *sqre == 0) { - sqrei = 0; - } else { - sqrei = 1; - } - idxqi += nlp1; - vfi += nlp1; - vli += nlp1; - nrp1 = nr + sqrei; - if (*icompq == 0) { - dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp, - (ftnlen)1); - dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & - work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], - &nr, &work[nwork2], info, (ftnlen)1); - itemp = nwork1 + (nrp1 - 1) * smlszp; - dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); - dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, ( - ftnlen)1); - dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], - ldu, (ftnlen)1); - dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & - vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + - u_dim1], ldu, &work[nwork1], info, (ftnlen)1); - dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); - dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) - ; - } - if (*info != 0) { - return 0; - } - i__2 = nr; - for (j = 1; j <= i__2; ++j) { - iwork[idxqi + j] = j; + } + if (i__ == nd && *sqre == 0) { + sqrei = 0; + } else { + sqrei = 1; + } + idxqi += nlp1; + vfi += nlp1; + vli += nlp1; + nrp1 = nr + sqrei; + if (*icompq == 0) { + dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp, + (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & + work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], + &nr, &work[nwork2], info, (ftnlen)1); + itemp = nwork1 + (nrp1 - 1) * smlszp; + dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, ( + ftnlen)1); + dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], + ldu, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & + vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + + u_dim1], ldu, &work[nwork1], info, (ftnlen)1); + dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; /* L20: */ - } + } /* L30: */ } @@ -555,61 +555,61 @@ f"> */ j = pow_ii(&c__2, &nlvl); for (lvl = nlvl; lvl >= 1; --lvl) { - lvl2 = (lvl << 1) - 1; + lvl2 = (lvl << 1) - 1; /* Find the first node LF and last node LL on */ /* the current level LVL. */ - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__1 = lvl - 1; - lf = pow_ii(&c__2, &i__1); - ll = (lf << 1) - 1; - } - i__1 = ll; - for (i__ = lf; i__ <= i__1; ++i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - if (i__ == ll) { - sqrei = *sqre; - } else { - sqrei = 1; - } - vfi = vf + nlf - 1; - vli = vl + nlf - 1; - idxqi = idxq + nlf - 1; - alpha = d__[ic]; - beta = e[ic]; - if (*icompq == 0) { - dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & - work[vli], &alpha, &beta, &iwork[idxqi], &perm[ - perm_offset], &givptr[1], &givcol[givcol_offset], - ldgcol, &givnum[givnum_offset], ldu, &poles[ - poles_offset], &difl[difl_offset], &difr[difr_offset], - &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], - &iwork[iwk], info); - } else { - --j; - dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & - work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + - lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * - givcol_dim1], ldgcol, &givnum[nlf + lvl2 * - givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & - difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * - difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], - &s[j], &work[nwork1], &iwork[iwk], info); - } - if (*info != 0) { - return 0; - } + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + idxqi = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + if (*icompq == 0) { + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[ + perm_offset], &givptr[1], &givcol[givcol_offset], + ldgcol, &givnum[givnum_offset], ldu, &poles[ + poles_offset], &difl[difl_offset], &difr[difr_offset], + &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], + &iwork[iwk], info); + } else { + --j; + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * + givcol_dim1], ldgcol, &givnum[nlf + lvl2 * + givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & + difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * + difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], + &s[j], &work[nwork1], &iwork[iwk], info); + } + if (*info != 0) { + return 0; + } /* L40: */ - } + } /* L50: */ } @@ -620,5 +620,5 @@ f"> */ } /* dlasda_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasdq.cpp b/lib/linalg/dlasdq.cpp index efb468cef4..418be52678 100644 --- a/lib/linalg/dlasdq.cpp +++ b/lib/linalg/dlasdq.cpp @@ -1,13 +1,13 @@ /* fortran/dlasdq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -232,14 +232,14 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer * - ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e, - doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, - doublereal *c__, integer *ldc, doublereal *work, integer *info, - ftnlen uplo_len) + ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e, + doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, + doublereal *c__, integer *ldc, doublereal *work, integer *info, + ftnlen uplo_len) { /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; /* Local variables */ integer i__, j; @@ -248,17 +248,17 @@ f"> */ doublereal smin; integer sqre1; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen, ftnlen), dswap_(integer *, doublereal *, integer * - , doublereal *, integer *); + extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen, ftnlen), dswap_(integer *, doublereal *, integer * + , doublereal *, integer *); integer iuplo; - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *), xerbla_(char *, - integer *, ftnlen), dbdsqr_(char *, integer *, integer *, integer - *, integer *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, ftnlen); + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), xerbla_(char *, + integer *, ftnlen), dbdsqr_(char *, integer *, integer *, integer + *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen); logical rotate; @@ -305,37 +305,37 @@ f"> */ *info = 0; iuplo = 0; if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - iuplo = 1; + iuplo = 1; } if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - iuplo = 2; + iuplo = 2; } if (iuplo == 0) { - *info = -1; + *info = -1; } else if (*sqre < 0 || *sqre > 1) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*ncvt < 0) { - *info = -4; + *info = -4; } else if (*nru < 0) { - *info = -5; + *info = -5; } else if (*ncc < 0) { - *info = -6; + *info = -6; } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) { - *info = -10; + *info = -10; } else if (*ldu < max(1,*nru)) { - *info = -12; + *info = -12; } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) { - *info = -14; + *info = -14; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASDQ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASDQ", &i__1, (ftnlen)6); + return 0; } if (*n == 0) { - return 0; + return 0; } /* ROTATE is true if any singular vectors desired, false otherwise */ @@ -348,92 +348,92 @@ f"> */ /* bidiagonal. The rotations are on the right. */ if (iuplo == 1 && sqre1 == 1) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (rotate) { - work[i__] = cs; - work[*n + i__] = sn; - } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } /* L10: */ - } - dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); - d__[*n] = r__; - e[*n] = 0.; - if (rotate) { - work[*n] = cs; - work[*n + *n] = sn; - } - iuplo = 2; - sqre1 = 0; + } + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + e[*n] = 0.; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + iuplo = 2; + sqre1 = 0; /* Update singular vectors if desired. */ - if (*ncvt > 0) { - dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[ - vt_offset], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (*ncvt > 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[ + vt_offset], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } } /* If matrix lower bidiagonal, rotate to be upper bidiagonal */ /* by applying Givens rotations on the left. */ if (iuplo == 2) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (rotate) { - work[i__] = cs; - work[*n + i__] = sn; - } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } /* L20: */ - } + } /* If matrix (N+1)-by-N lower bidiagonal, one additional */ /* rotation is needed. */ - if (sqre1 == 1) { - dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); - d__[*n] = r__; - if (rotate) { - work[*n] = cs; - work[*n + *n] = sn; - } - } + if (sqre1 == 1) { + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + } /* Update singular vectors if desired. */ - if (*nru > 0) { - if (sqre1 == 0) { - dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[ - u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } else { - dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[ - u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - } - if (*ncc > 0) { - if (sqre1 == 0) { - dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } else { - dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } - } + if (*nru > 0) { + if (sqre1 == 0) { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[ + u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[ + u_offset], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } + if (*ncc > 0) { + if (sqre1 == 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } } /* Call DBDSQR to compute the SVD of the reduced real */ /* N-by-N upper bidiagonal matrix. */ dbdsqr_((char *)"U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ - u_offset], ldu, &c__[c_offset], ldc, &work[1], info, (ftnlen)1); + u_offset], ldu, &c__[c_offset], ldc, &work[1], info, (ftnlen)1); /* Sort the singular values into ascending order (insertion sort on */ /* singular values, but only one transposition per singular vector) */ @@ -443,35 +443,35 @@ f"> */ /* Scan for smallest D(I). */ - isub = i__; - smin = d__[i__]; - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - if (d__[j] < smin) { - isub = j; - smin = d__[j]; - } + isub = i__; + smin = d__[i__]; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (d__[j] < smin) { + isub = j; + smin = d__[j]; + } /* L30: */ - } - if (isub != i__) { + } + if (isub != i__) { /* Swap singular values and vectors. */ - d__[isub] = d__[i__]; - d__[i__] = smin; - if (*ncvt > 0) { - dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], - ldvt); - } - if (*nru > 0) { - dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] - , &c__1); - } - if (*ncc > 0) { - dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) - ; - } - } + d__[isub] = d__[i__]; + d__[i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], + ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] + , &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) + ; + } + } /* L40: */ } @@ -482,5 +482,5 @@ f"> */ } /* dlasdq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasdt.cpp b/lib/linalg/dlasdt.cpp index 0e507af8f2..77edcf93d4 100644 --- a/lib/linalg/dlasdt.cpp +++ b/lib/linalg/dlasdt.cpp @@ -1,13 +1,13 @@ /* fortran/dlasdt.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -122,7 +122,7 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer * - inode, integer *ndiml, integer *ndimr, integer *msub) + inode, integer *ndiml, integer *ndimr, integer *msub) { /* System generated locals */ integer i__1, i__2; @@ -180,20 +180,20 @@ f"> */ /* Constructing the tree at (NLVL+1)-st level. The number of */ /* nodes created on this level is LLST * 2. */ - i__2 = llst - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - il += 2; - ir += 2; - ncrnt = llst + i__; - ndiml[il] = ndiml[ncrnt] / 2; - ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; - inode[il] = inode[ncrnt] - ndimr[il] - 1; - ndiml[ir] = ndimr[ncrnt] / 2; - ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; - inode[ir] = inode[ncrnt] + ndiml[ir] + 1; + i__2 = llst - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + il += 2; + ir += 2; + ncrnt = llst + i__; + ndiml[il] = ndiml[ncrnt] / 2; + ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; + inode[il] = inode[ncrnt] - ndimr[il] - 1; + ndiml[ir] = ndimr[ncrnt] / 2; + ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; + inode[ir] = inode[ncrnt] + ndiml[ir] + 1; /* L10: */ - } - llst <<= 1; + } + llst <<= 1; /* L20: */ } *nd = (llst << 1) - 1; @@ -205,5 +205,5 @@ f"> */ } /* dlasdt_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaset.cpp b/lib/linalg/dlaset.cpp index 072bbf1500..4323f948e4 100644 --- a/lib/linalg/dlaset.cpp +++ b/lib/linalg/dlaset.cpp @@ -1,13 +1,13 @@ /* fortran/dlaset.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,7 +128,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal * - alpha, doublereal *beta, doublereal *a, integer *lda, ftnlen uplo_len) + alpha, doublereal *beta, doublereal *a, integer *lda, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -168,53 +168,53 @@ f"> */ /* Set the strictly upper triangular or trapezoidal part of the */ /* array to ALPHA. */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { /* Computing MIN */ - i__3 = j - 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; + i__3 = j - 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; /* L10: */ - } + } /* L20: */ - } + } } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Set the strictly lower triangular or trapezoidal part of the */ /* array to ALPHA. */ - i__1 = min(*m,*n); - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; + i__1 = min(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; /* L30: */ - } + } /* L40: */ - } + } } else { /* Set the leading m-by-n submatrix to ALPHA. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; /* L50: */ - } + } /* L60: */ - } + } } /* Set the first min(M,N) diagonal elements to BETA. */ i__1 = min(*m,*n); for (i__ = 1; i__ <= i__1; ++i__) { - a[i__ + i__ * a_dim1] = *beta; + a[i__ + i__ * a_dim1] = *beta; /* L70: */ } @@ -225,5 +225,5 @@ f"> */ } /* dlaset_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq1.cpp b/lib/linalg/dlasq1.cpp index 090f680525..0c9e0ca9f2 100644 --- a/lib/linalg/dlasq1.cpp +++ b/lib/linalg/dlasq1.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq1.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -130,8 +130,8 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, - doublereal *work, integer *info) +/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, + doublereal *work, integer *info) { /* System generated locals */ integer i__1, i__2; @@ -143,22 +143,22 @@ f"> */ /* Local variables */ integer i__; doublereal eps; - extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); + extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); doublereal scale; integer iinfo; doublereal sigmn; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); doublereal sigmx; extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *); extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen); doublereal safmin; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlasrt_( - char *, integer *, doublereal *, integer *, ftnlen); + char *, integer *, doublereal *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -192,20 +192,20 @@ f"> */ /* Function Body */ *info = 0; if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_((char *)"DLASQ1", &i__1, (ftnlen)6); - return 0; + *info = -1; + i__1 = -(*info); + xerbla_((char *)"DLASQ1", &i__1, (ftnlen)6); + return 0; } else if (*n == 0) { - return 0; + return 0; } else if (*n == 1) { - d__[1] = abs(d__[1]); - return 0; + d__[1] = abs(d__[1]); + return 0; } else if (*n == 2) { - dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); - d__[1] = sigmx; - d__[2] = sigmn; - return 0; + dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); + d__[1] = sigmx; + d__[2] = sigmn; + return 0; } /* Estimate the largest singular value. */ @@ -213,10 +213,10 @@ f"> */ sigmx = 0.; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = (d__1 = d__[i__], abs(d__1)); + d__[i__] = (d__1 = d__[i__], abs(d__1)); /* Computing MAX */ - d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); - sigmx = max(d__2,d__3); + d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); + sigmx = max(d__2,d__3); /* L10: */ } d__[*n] = (d__1 = d__[*n], abs(d__1)); @@ -224,15 +224,15 @@ f"> */ /* Early return if SIGMX is zero (matrix is already diagonal). */ if (sigmx == 0.) { - dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1); - return 0; + dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1); + return 0; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ - d__1 = sigmx, d__2 = d__[i__]; - sigmx = max(d__1,d__2); + d__1 = sigmx, d__2 = d__[i__]; + sigmx = max(d__1,d__2); /* L20: */ } @@ -247,16 +247,16 @@ f"> */ dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); i__1 = (*n << 1) - 1; i__2 = (*n << 1) - 1; - dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, - &iinfo, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, + &iinfo, (ftnlen)1); /* Compute the q's and e's. */ i__1 = (*n << 1) - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing 2nd power */ - d__1 = work[i__]; - work[i__] = d__1 * d__1; + d__1 = work[i__]; + work[i__] = d__1 * d__1; /* L30: */ } work[*n * 2] = 0.; @@ -264,27 +264,27 @@ f"> */ dlasq2_(n, &work[1], info); if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(work[i__]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[i__]); /* L40: */ - } - dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & - iinfo, (ftnlen)1); + } + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo, (ftnlen)1); } else if (*info == 2) { /* Maximum number of iterations exceeded. Move data from WORK */ /* into D and E so the calling subroutine can try to finish */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(work[(i__ << 1) - 1]); - e[i__] = sqrt(work[i__ * 2]); - } - dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & - iinfo, (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo, - (ftnlen)1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[(i__ << 1) - 1]); + e[i__] = sqrt(work[i__ * 2]); + } + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo, + (ftnlen)1); } return 0; @@ -294,5 +294,5 @@ f"> */ } /* dlasq1_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq2.cpp b/lib/linalg/dlasq2.cpp index a6362ecfdf..c9e4b30884 100644 --- a/lib/linalg/dlasq2.cpp +++ b/lib/linalg/dlasq2.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -168,20 +168,20 @@ f"> */ integer iinfo; doublereal tempe, tempq; integer ttype; - extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, integer *, integer *, logical *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *, logical *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); extern doublereal dlamch_(char *, ftnlen); doublereal deemin; integer iwhila, iwhilb; doublereal oldemn, safmin; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -223,57 +223,57 @@ f"> */ tol2 = d__1 * d__1; if (*n < 0) { - *info = -1; - xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6); - return 0; + *info = -1; + xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6); + return 0; } else if (*n == 0) { - return 0; + return 0; } else if (*n == 1) { /* 1-by-1 case. */ - if (z__[1] < 0.) { - *info = -201; - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - } - return 0; + if (z__[1] < 0.) { + *info = -201; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + } + return 0; } else if (*n == 2) { /* 2-by-2 case. */ - if (z__[1] < 0.) { - *info = -201; - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; - } else if (z__[2] < 0.) { - *info = -202; - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; - } else if (z__[3] < 0.) { - *info = -203; - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; - } else if (z__[3] > z__[1]) { - d__ = z__[3]; - z__[3] = z__[1]; - z__[1] = d__; - } - z__[5] = z__[1] + z__[2] + z__[3]; - if (z__[2] > z__[3] * tol2) { - t = (z__[1] - z__[3] + z__[2]) * .5; - s = z__[3] * (z__[2] / t); - if (s <= t) { - s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[1] + (s + z__[2]); - z__[3] *= z__[1] / t; - z__[1] = t; - } - z__[2] = z__[3]; - z__[6] = z__[2] + z__[1]; - return 0; + if (z__[1] < 0.) { + *info = -201; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[2] < 0.) { + *info = -202; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] < 0.) { + *info = -203; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] > z__[1]) { + d__ = z__[3]; + z__[3] = z__[1]; + z__[1] = d__; + } + z__[5] = z__[1] + z__[2] + z__[3]; + if (z__[2] > z__[3] * tol2) { + t = (z__[1] - z__[3] + z__[2]) * .5; + s = z__[3] * (z__[2] / t); + if (s <= t) { + s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[1] + (s + z__[2]); + z__[3] *= z__[1] / t; + z__[1] = t; + } + z__[2] = z__[3]; + z__[6] = z__[2] + z__[1]; + return 0; } /* Check for negative data and compute sums of q's and e's. */ @@ -287,32 +287,32 @@ f"> */ i__1 = *n - 1 << 1; for (k = 1; k <= i__1; k += 2) { - if (z__[k] < 0.) { - *info = -(k + 200); - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; - } else if (z__[k + 1] < 0.) { - *info = -(k + 201); - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; - } - d__ += z__[k]; - e += z__[k + 1]; + if (z__[k] < 0.) { + *info = -(k + 200); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[k + 1] < 0.) { + *info = -(k + 201); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } + d__ += z__[k]; + e += z__[k + 1]; /* Computing MAX */ - d__1 = qmax, d__2 = z__[k]; - qmax = max(d__1,d__2); + d__1 = qmax, d__2 = z__[k]; + qmax = max(d__1,d__2); /* Computing MIN */ - d__1 = emin, d__2 = z__[k + 1]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[k + 1]; + emin = min(d__1,d__2); /* Computing MAX */ - d__1 = max(qmax,zmax), d__2 = z__[k + 1]; - zmax = max(d__1,d__2); + d__1 = max(qmax,zmax), d__2 = z__[k + 1]; + zmax = max(d__1,d__2); /* L10: */ } if (z__[(*n << 1) - 1] < 0.) { - *info = -((*n << 1) + 199); - xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); - return 0; + *info = -((*n << 1) + 199); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; } d__ += z__[(*n << 1) - 1]; /* Computing MAX */ @@ -323,14 +323,14 @@ f"> */ /* Check for diagonality. */ if (e == 0.) { - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 1) - 1]; + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 1) - 1]; /* L20: */ - } - dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1); - z__[(*n << 1) - 1] = d__; - return 0; + } + dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1); + z__[(*n << 1) - 1] = d__; + return 0; } trace = d__ + e; @@ -338,22 +338,22 @@ f"> */ /* Check for zero data. */ if (trace == 0.) { - z__[(*n << 1) - 1] = 0.; - return 0; + z__[(*n << 1) - 1] = 0.; + return 0; } /* Check whether the machine is IEEE conformable. */ ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen) - 6, (ftnlen)1) == 1; + 6, (ftnlen)1) == 1; /* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ for (k = *n << 1; k >= 2; k += -2) { - z__[k * 2] = 0.; - z__[(k << 1) - 1] = z__[k]; - z__[(k << 1) - 2] = 0.; - z__[(k << 1) - 3] = z__[k - 1]; + z__[k * 2] = 0.; + z__[(k << 1) - 1] = z__[k]; + z__[(k << 1) - 2] = 0.; + z__[(k << 1) - 3] = z__[k - 1]; /* L30: */ } @@ -363,17 +363,17 @@ f"> */ /* Reverse the qd-array, if warranted. */ if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { - ipn4 = i0 + n0 << 2; - i__1 = i0 + n0 - 1 << 1; - for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { - temp = z__[i4 - 3]; - z__[i4 - 3] = z__[ipn4 - i4 - 3]; - z__[ipn4 - i4 - 3] = temp; - temp = z__[i4 - 1]; - z__[i4 - 1] = z__[ipn4 - i4 - 5]; - z__[ipn4 - i4 - 5] = temp; + ipn4 = i0 + n0 << 2; + i__1 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; /* L40: */ - } + } } /* Initial split checking via dqd and Li's test. */ @@ -382,61 +382,61 @@ f"> */ for (k = 1; k <= 2; ++k) { - d__ = z__[(n0 << 2) + pp - 3]; - i__1 = (i0 << 2) + pp; - for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = -0.; - d__ = z__[i4 - 3]; - } else { - d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); - } + d__ = z__[(n0 << 2) + pp - 3]; + i__1 = (i0 << 2) + pp; + for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + d__ = z__[i4 - 3]; + } else { + d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); + } /* L50: */ - } + } /* dqd maps Z to ZZ plus Li's test. */ - emin = z__[(i0 << 2) + pp + 1]; - d__ = z__[(i0 << 2) + pp - 3]; - i__1 = (n0 - 1 << 2) + pp; - for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { - z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = -0.; - z__[i4 - (pp << 1) - 2] = d__; - z__[i4 - (pp << 1)] = 0.; - d__ = z__[i4 + 1]; - } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && - safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { - temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; - z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; - d__ *= temp; - } else { - z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( - pp << 1) - 2]); - d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); - } + emin = z__[(i0 << 2) + pp + 1]; + d__ = z__[(i0 << 2) + pp - 3]; + i__1 = (n0 - 1 << 2) + pp; + for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { + z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + z__[i4 - (pp << 1) - 2] = d__; + z__[i4 - (pp << 1)] = 0.; + d__ = z__[i4 + 1]; + } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && + safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { + temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; + z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; + d__ *= temp; + } else { + z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( + pp << 1) - 2]); + d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); + } /* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - (pp << 1)]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[i4 - (pp << 1)]; + emin = min(d__1,d__2); /* L60: */ - } - z__[(n0 << 2) - pp - 2] = d__; + } + z__[(n0 << 2) - pp - 2] = d__; /* Now find qmax. */ - qmax = z__[(i0 << 2) - pp - 2]; - i__1 = (n0 << 2) - pp - 2; - for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { + qmax = z__[(i0 << 2) - pp - 2]; + i__1 = (n0 << 2) - pp - 2; + for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { /* Computing MAX */ - d__1 = qmax, d__2 = z__[i4]; - qmax = max(d__1,d__2); + d__1 = qmax, d__2 = z__[i4]; + qmax = max(d__1,d__2); /* L70: */ - } + } /* Prepare for the next iteration on K. */ - pp = 1 - pp; + pp = 1 - pp; /* L80: */ } @@ -457,104 +457,104 @@ f"> */ i__1 = *n + 1; for (iwhila = 1; iwhila <= i__1; ++iwhila) { - if (n0 < 1) { - goto L170; - } + if (n0 < 1) { + goto L170; + } /* While array unfinished do */ /* E(N0) holds the value of SIGMA when submatrix in I0:N0 */ /* splits from the rest of the array, but is negated. */ - desig = 0.; - if (n0 == *n) { - sigma = 0.; - } else { - sigma = -z__[(n0 << 2) - 1]; - } - if (sigma < 0.) { - *info = 1; - return 0; - } + desig = 0.; + if (n0 == *n) { + sigma = 0.; + } else { + sigma = -z__[(n0 << 2) - 1]; + } + if (sigma < 0.) { + *info = 1; + return 0; + } /* Find last unreduced submatrix's top index I0, find QMAX and */ /* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ - emax = 0.; - if (n0 > i0) { - emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); - } else { - emin = 0.; - } - qmin = z__[(n0 << 2) - 3]; - qmax = qmin; - for (i4 = n0 << 2; i4 >= 8; i4 += -4) { - if (z__[i4 - 5] <= 0.) { - goto L100; - } - if (qmin >= emax * 4.) { + emax = 0.; + if (n0 > i0) { + emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); + } else { + emin = 0.; + } + qmin = z__[(n0 << 2) - 3]; + qmax = qmin; + for (i4 = n0 << 2; i4 >= 8; i4 += -4) { + if (z__[i4 - 5] <= 0.) { + goto L100; + } + if (qmin >= emax * 4.) { /* Computing MIN */ - d__1 = qmin, d__2 = z__[i4 - 3]; - qmin = min(d__1,d__2); + d__1 = qmin, d__2 = z__[i4 - 3]; + qmin = min(d__1,d__2); /* Computing MAX */ - d__1 = emax, d__2 = z__[i4 - 5]; - emax = max(d__1,d__2); - } + d__1 = emax, d__2 = z__[i4 - 5]; + emax = max(d__1,d__2); + } /* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; - qmax = max(d__1,d__2); + d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; + qmax = max(d__1,d__2); /* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 5]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[i4 - 5]; + emin = min(d__1,d__2); /* L90: */ - } - i4 = 4; + } + i4 = 4; L100: - i0 = i4 / 4; - pp = 0; + i0 = i4 / 4; + pp = 0; - if (n0 - i0 > 1) { - dee = z__[(i0 << 2) - 3]; - deemin = dee; - kmin = i0; - i__2 = (n0 << 2) - 3; - for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { - dee = z__[i4] * (dee / (dee + z__[i4 - 2])); - if (dee <= deemin) { - deemin = dee; - kmin = (i4 + 3) / 4; - } + if (n0 - i0 > 1) { + dee = z__[(i0 << 2) - 3]; + deemin = dee; + kmin = i0; + i__2 = (n0 << 2) - 3; + for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { + dee = z__[i4] * (dee / (dee + z__[i4 - 2])); + if (dee <= deemin) { + deemin = dee; + kmin = (i4 + 3) / 4; + } /* L110: */ - } - if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * - .5) { - ipn4 = i0 + n0 << 2; - pp = 2; - i__2 = i0 + n0 - 1 << 1; - for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { - temp = z__[i4 - 3]; - z__[i4 - 3] = z__[ipn4 - i4 - 3]; - z__[ipn4 - i4 - 3] = temp; - temp = z__[i4 - 2]; - z__[i4 - 2] = z__[ipn4 - i4 - 2]; - z__[ipn4 - i4 - 2] = temp; - temp = z__[i4 - 1]; - z__[i4 - 1] = z__[ipn4 - i4 - 5]; - z__[ipn4 - i4 - 5] = temp; - temp = z__[i4]; - z__[i4] = z__[ipn4 - i4 - 4]; - z__[ipn4 - i4 - 4] = temp; + } + if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * + .5) { + ipn4 = i0 + n0 << 2; + pp = 2; + i__2 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 2]; + z__[i4 - 2] = z__[ipn4 - i4 - 2]; + z__[ipn4 - i4 - 2] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; + temp = z__[i4]; + z__[i4] = z__[ipn4 - i4 - 4]; + z__[ipn4 - i4 - 4] = temp; /* L120: */ - } - } - } + } + } + } /* Put -(initial shift) into DMIN. */ /* Computing MAX */ - d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); - dmin__ = -max(d__1,d__2); + d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); + dmin__ = -max(d__1,d__2); /* Now I0:N0 is unreduced. */ /* PP = 0 for ping, PP = 1 for pong. */ @@ -562,113 +562,113 @@ L100: /* and that the tests for deflation upon entry in DLASQ3 */ /* should not be performed. */ - nbig = (n0 - i0 + 1) * 100; - i__2 = nbig; - for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { - if (i0 > n0) { - goto L150; - } + nbig = (n0 - i0 + 1) * 100; + i__2 = nbig; + for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { + if (i0 > n0) { + goto L150; + } /* While submatrix unfinished take a good dqds step. */ - dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & - nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & - dn1, &dn2, &g, &tau); + dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & + nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & + dn1, &dn2, &g, &tau); - pp = 1 - pp; + pp = 1 - pp; /* When EMIN is very small check for splits. */ - if (pp == 0 && n0 - i0 >= 3) { - if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * - sigma) { - splt = i0 - 1; - qmax = z__[(i0 << 2) - 3]; - emin = z__[(i0 << 2) - 1]; - oldemn = z__[i0 * 4]; - i__3 = n0 - 3 << 2; - for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { - if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= - tol2 * sigma) { - z__[i4 - 1] = -sigma; - splt = i4 / 4; - qmax = 0.; - emin = z__[i4 + 3]; - oldemn = z__[i4 + 4]; - } else { + if (pp == 0 && n0 - i0 >= 3) { + if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * + sigma) { + splt = i0 - 1; + qmax = z__[(i0 << 2) - 3]; + emin = z__[(i0 << 2) - 1]; + oldemn = z__[i0 * 4]; + i__3 = n0 - 3 << 2; + for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { + if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= + tol2 * sigma) { + z__[i4 - 1] = -sigma; + splt = i4 / 4; + qmax = 0.; + emin = z__[i4 + 3]; + oldemn = z__[i4 + 4]; + } else { /* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 + 1]; - qmax = max(d__1,d__2); + d__1 = qmax, d__2 = z__[i4 + 1]; + qmax = max(d__1,d__2); /* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 1]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[i4 - 1]; + emin = min(d__1,d__2); /* Computing MIN */ - d__1 = oldemn, d__2 = z__[i4]; - oldemn = min(d__1,d__2); - } + d__1 = oldemn, d__2 = z__[i4]; + oldemn = min(d__1,d__2); + } /* L130: */ - } - z__[(n0 << 2) - 1] = emin; - z__[n0 * 4] = oldemn; - i0 = splt + 1; - } - } + } + z__[(n0 << 2) - 1] = emin; + z__[n0 * 4] = oldemn; + i0 = splt + 1; + } + } /* L140: */ - } + } - *info = 2; + *info = 2; /* Maximum number of iterations exceeded, restore the shift */ /* SIGMA and place the new d's and e's in a qd array. */ /* This might need to be done for several blocks */ - i1 = i0; - n1 = n0; + i1 = i0; + n1 = n0; L145: - tempq = z__[(i0 << 2) - 3]; - z__[(i0 << 2) - 3] += sigma; - i__2 = n0; - for (k = i0 + 1; k <= i__2; ++k) { - tempe = z__[(k << 2) - 5]; - z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; - tempq = z__[(k << 2) - 3]; - z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << - 2) - 5]; - } + tempq = z__[(i0 << 2) - 3]; + z__[(i0 << 2) - 3] += sigma; + i__2 = n0; + for (k = i0 + 1; k <= i__2; ++k) { + tempe = z__[(k << 2) - 5]; + z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; + tempq = z__[(k << 2) - 3]; + z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << + 2) - 5]; + } /* Prepare to do this on the previous block if there is one */ - if (i1 > 1) { - n1 = i1 - 1; - while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) { - --i1; - } - sigma = -z__[(n1 << 2) - 1]; - goto L145; - } - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - z__[(k << 1) - 1] = z__[(k << 2) - 3]; + if (i1 > 1) { + n1 = i1 - 1; + while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) { + --i1; + } + sigma = -z__[(n1 << 2) - 1]; + goto L145; + } + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + z__[(k << 1) - 1] = z__[(k << 2) - 3]; /* Only the block 1..N0 is unfinished. The rest of the e's */ /* must be essentially zero, although sometimes other data */ /* has been stored in them. */ - if (k < n0) { - z__[k * 2] = z__[(k << 2) - 1]; - } else { - z__[k * 2] = 0.; - } - } - return 0; + if (k < n0) { + z__[k * 2] = z__[(k << 2) - 1]; + } else { + z__[k * 2] = 0.; + } + } + return 0; /* end IWHILB */ L150: /* L160: */ - ; + ; } *info = 3; @@ -682,7 +682,7 @@ L170: i__1 = *n; for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 2) - 3]; + z__[k] = z__[(k << 2) - 3]; /* L180: */ } @@ -692,7 +692,7 @@ L170: e = 0.; for (k = *n; k >= 1; --k) { - e += z__[k]; + e += z__[k]; /* L190: */ } @@ -712,5 +712,5 @@ L170: } /* dlasq2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq3.cpp b/lib/linalg/dlasq3.cpp index e5974545a6..f43c67ca34 100644 --- a/lib/linalg/dlasq3.cpp +++ b/lib/linalg/dlasq3.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq3.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -196,12 +196,12 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig, - doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, - logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2, - doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, - doublereal *tau) +/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__, + integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig, + doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, + logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2, + doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, + doublereal *tau) { /* System generated locals */ integer i__1; @@ -216,15 +216,15 @@ f"> */ doublereal eps, tol; integer n0in, ipn4; doublereal tol2, temp; - extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *), dlasq5_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, logical * - , doublereal *), dlasq6_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *); + extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *), dlasq5_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, logical * + , doublereal *), dlasq6_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *); extern doublereal dlamch_(char *, ftnlen); extern logical disnan_(doublereal *); @@ -268,21 +268,21 @@ f"> */ L10: if (*n0 < *i0) { - return 0; + return 0; } if (*n0 == *i0) { - goto L20; + goto L20; } nn = (*n0 << 2) + *pp; if (*n0 == *i0 + 1) { - goto L40; + goto L40; } /* Check whether E(N0-1) is negligible, 1 eigenvalue. */ - if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - - 4] > tol2 * z__[nn - 7]) { - goto L30; + if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - + 4] > tol2 * z__[nn - 7]) { + goto L30; } L20: @@ -296,28 +296,28 @@ L20: L30: if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ - nn - 11]) { - goto L50; + nn - 11]) { + goto L50; } L40: if (z__[nn - 3] > z__[nn - 7]) { - s = z__[nn - 3]; - z__[nn - 3] = z__[nn - 7]; - z__[nn - 7] = s; + s = z__[nn - 3]; + z__[nn - 3] = z__[nn - 7]; + z__[nn - 7] = s; } t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.) { - s = z__[nn - 3] * (z__[nn - 5] / t); - if (s <= t) { - s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[nn - 7] + (s + z__[nn - 5]); - z__[nn - 3] *= z__[nn - 7] / t; - z__[nn - 7] = t; + s = z__[nn - 3] * (z__[nn - 5] / t); + if (s <= t) { + s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[nn - 7] + (s + z__[nn - 5]); + z__[nn - 3] *= z__[nn - 7] / t; + z__[nn - 7] = t; } z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; @@ -326,64 +326,64 @@ L40: L50: if (*pp == 2) { - *pp = 0; + *pp = 0; } /* Reverse the qd-array, if warranted. */ if (*dmin__ <= 0. || *n0 < n0in) { - if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { - ipn4 = *i0 + *n0 << 2; - i__1 = *i0 + *n0 - 1 << 1; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - temp = z__[j4 - 3]; - z__[j4 - 3] = z__[ipn4 - j4 - 3]; - z__[ipn4 - j4 - 3] = temp; - temp = z__[j4 - 2]; - z__[j4 - 2] = z__[ipn4 - j4 - 2]; - z__[ipn4 - j4 - 2] = temp; - temp = z__[j4 - 1]; - z__[j4 - 1] = z__[ipn4 - j4 - 5]; - z__[ipn4 - j4 - 5] = temp; - temp = z__[j4]; - z__[j4] = z__[ipn4 - j4 - 4]; - z__[ipn4 - j4 - 4] = temp; + if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { + ipn4 = *i0 + *n0 << 2; + i__1 = *i0 + *n0 - 1 << 1; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + temp = z__[j4 - 3]; + z__[j4 - 3] = z__[ipn4 - j4 - 3]; + z__[ipn4 - j4 - 3] = temp; + temp = z__[j4 - 2]; + z__[j4 - 2] = z__[ipn4 - j4 - 2]; + z__[ipn4 - j4 - 2] = temp; + temp = z__[j4 - 1]; + z__[j4 - 1] = z__[ipn4 - j4 - 5]; + z__[ipn4 - j4 - 5] = temp; + temp = z__[j4]; + z__[j4] = z__[ipn4 - j4 - 4]; + z__[ipn4 - j4 - 4] = temp; /* L60: */ - } - if (*n0 - *i0 <= 4) { - z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; - z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; - } + } + if (*n0 - *i0 <= 4) { + z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; + z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; + } /* Computing MIN */ - d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; - *dmin2 = min(d__1,d__2); + d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; + *dmin2 = min(d__1,d__2); /* Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] - , d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; - z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2); + d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] + , d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; + z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2); /* Computing MIN */ - d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = - min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; - z__[(*n0 << 2) - *pp] = min(d__1,d__2); + d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = + min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; + z__[(*n0 << 2) - *pp] = min(d__1,d__2); /* Computing MAX */ - d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, - d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; - *qmax = max(d__1,d__2); - *dmin__ = -0.; - } + d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, + d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; + *qmax = max(d__1,d__2); + *dmin__ = -0.; + } } /* Choose a shift. */ - dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, - tau, ttype, g); + dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, + tau, ttype, g); /* Call dqds until DMIN > 0. */ L70: - dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, - dn2, ieee, &eps); + dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, + dn2, ieee, &eps); *ndiv += *n0 - *i0 + 2; ++(*iter); @@ -394,55 +394,55 @@ L70: /* Success. */ - goto L90; + goto L90; - } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol - * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { + } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol + * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { /* Convergence hidden by negative DN. */ - z__[(*n0 - 1 << 2) - *pp + 2] = 0.; - *dmin__ = 0.; - goto L90; + z__[(*n0 - 1 << 2) - *pp + 2] = 0.; + *dmin__ = 0.; + goto L90; } else if (*dmin__ < 0.) { /* TAU too big. Select new TAU and try again. */ - ++(*nfail); - if (*ttype < -22) { + ++(*nfail); + if (*ttype < -22) { /* Failed twice. Play it safe. */ - *tau = 0.; - } else if (*dmin1 > 0.) { + *tau = 0.; + } else if (*dmin1 > 0.) { /* Late failure. Gives excellent shift. */ - *tau = (*tau + *dmin__) * (1. - eps * 2.); - *ttype += -11; - } else { + *tau = (*tau + *dmin__) * (1. - eps * 2.); + *ttype += -11; + } else { /* Early failure. Divide by 4. */ - *tau *= .25; - *ttype += -12; - } - goto L70; + *tau *= .25; + *ttype += -12; + } + goto L70; } else if (disnan_(dmin__)) { /* NaN. */ - if (*tau == 0.) { - goto L80; - } else { - *tau = 0.; - goto L70; - } + if (*tau == 0.) { + goto L80; + } else { + *tau = 0.; + goto L70; + } } else { /* Possible underflow. Play it safe. */ - goto L80; + goto L80; } /* Risk of underflow. */ @@ -455,12 +455,12 @@ L80: L90: if (*tau < *sigma) { - *desig += *tau; - t = *sigma + *desig; - *desig -= t - *sigma; + *desig += *tau; + t = *sigma + *desig; + *desig -= t - *sigma; } else { - t = *sigma + *tau; - *desig = *sigma - (t - *tau) + *desig; + t = *sigma + *tau; + *desig = *sigma - (t - *tau) + *desig; } *sigma = t; @@ -471,5 +471,5 @@ L90: } /* dlasq3_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq4.cpp b/lib/linalg/dlasq4.cpp index 4841ada1d2..9629f53161 100644 --- a/lib/linalg/dlasq4.cpp +++ b/lib/linalg/dlasq4.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq4.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -167,10 +167,10 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__, - integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1, - doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, - doublereal *tau, integer *ttype, doublereal *g) +/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__, + integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1, + doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, + doublereal *tau, integer *ttype, doublereal *g) { /* System generated locals */ integer i__1; @@ -212,9 +212,9 @@ f"> */ /* Function Body */ if (*dmin__ <= 0.) { - *tau = -(*dmin__); - *ttype = -1; - return 0; + *tau = -(*dmin__); + *ttype = -1; + return 0; } nn = (*n0 << 2) + *pp; @@ -222,215 +222,215 @@ f"> */ /* No eigenvalues deflated. */ - if (*dmin__ == *dn || *dmin__ == *dn1) { + if (*dmin__ == *dn || *dmin__ == *dn1) { - b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); - b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); - a2 = z__[nn - 7] + z__[nn - 5]; + b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); + b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); + a2 = z__[nn - 7] + z__[nn - 5]; /* Cases 2 and 3. */ - if (*dmin__ == *dn && *dmin1 == *dn1) { - gap2 = *dmin2 - a2 - *dmin2 * .25; - if (gap2 > 0. && gap2 > b2) { - gap1 = a2 - *dn - b2 / gap2 * b2; - } else { - gap1 = a2 - *dn - (b1 + b2); - } - if (gap1 > 0. && gap1 > b1) { + if (*dmin__ == *dn && *dmin1 == *dn1) { + gap2 = *dmin2 - a2 - *dmin2 * .25; + if (gap2 > 0. && gap2 > b2) { + gap1 = a2 - *dn - b2 / gap2 * b2; + } else { + gap1 = a2 - *dn - (b1 + b2); + } + if (gap1 > 0. && gap1 > b1) { /* Computing MAX */ - d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; - s = max(d__1,d__2); - *ttype = -2; - } else { - s = 0.; - if (*dn > b1) { - s = *dn - b1; - } - if (a2 > b1 + b2) { + d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; + s = max(d__1,d__2); + *ttype = -2; + } else { + s = 0.; + if (*dn > b1) { + s = *dn - b1; + } + if (a2 > b1 + b2) { /* Computing MIN */ - d__1 = s, d__2 = a2 - (b1 + b2); - s = min(d__1,d__2); - } + d__1 = s, d__2 = a2 - (b1 + b2); + s = min(d__1,d__2); + } /* Computing MAX */ - d__1 = s, d__2 = *dmin__ * .333; - s = max(d__1,d__2); - *ttype = -3; - } - } else { + d__1 = s, d__2 = *dmin__ * .333; + s = max(d__1,d__2); + *ttype = -3; + } + } else { /* Case 4. */ - *ttype = -4; - s = *dmin__ * .25; - if (*dmin__ == *dn) { - gam = *dn; - a2 = 0.; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b2 = z__[nn - 5] / z__[nn - 7]; - np = nn - 9; - } else { - np = nn - (*pp << 1); - gam = *dn1; - if (z__[np - 4] > z__[np - 2]) { - return 0; - } - a2 = z__[np - 4] / z__[np - 2]; - if (z__[nn - 9] > z__[nn - 11]) { - return 0; - } - b2 = z__[nn - 9] / z__[nn - 11]; - np = nn - 13; - } + *ttype = -4; + s = *dmin__ * .25; + if (*dmin__ == *dn) { + gam = *dn; + a2 = 0.; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b2 = z__[nn - 5] / z__[nn - 7]; + np = nn - 9; + } else { + np = nn - (*pp << 1); + gam = *dn1; + if (z__[np - 4] > z__[np - 2]) { + return 0; + } + a2 = z__[np - 4] / z__[np - 2]; + if (z__[nn - 9] > z__[nn - 11]) { + return 0; + } + b2 = z__[nn - 9] / z__[nn - 11]; + np = nn - 13; + } /* Approximate contribution to norm squared from I < NN-1. */ - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = np; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L20; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (max(b2,b1) * 100. < a2 || .563 < a2) { - goto L20; - } + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = np; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L20; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (max(b2,b1) * 100. < a2 || .563 < a2) { + goto L20; + } /* L10: */ - } + } L20: - a2 *= 1.05; + a2 *= 1.05; /* Rayleigh quotient residual bound. */ - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } - } else if (*dmin__ == *dn2) { + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } + } else if (*dmin__ == *dn2) { /* Case 5. */ - *ttype = -5; - s = *dmin__ * .25; + *ttype = -5; + s = *dmin__ * .25; /* Compute contribution to norm squared from I > NN-2. */ - np = nn - (*pp << 1); - b1 = z__[np - 2]; - b2 = z__[np - 6]; - gam = *dn2; - if (z__[np - 8] > b2 || z__[np - 4] > b1) { - return 0; - } - a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); + np = nn - (*pp << 1); + b1 = z__[np - 2]; + b2 = z__[np - 6]; + gam = *dn2; + if (z__[np - 8] > b2 || z__[np - 4] > b1) { + return 0; + } + a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); /* Approximate contribution to norm squared from I < NN-2. */ - if (*n0 - *i0 > 2) { - b2 = z__[nn - 13] / z__[nn - 15]; - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = nn - 17; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L40; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (max(b2,b1) * 100. < a2 || .563 < a2) { - goto L40; - } + if (*n0 - *i0 > 2) { + b2 = z__[nn - 13] / z__[nn - 15]; + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = nn - 17; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L40; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (max(b2,b1) * 100. < a2 || .563 < a2) { + goto L40; + } /* L30: */ - } + } L40: - a2 *= 1.05; - } + a2 *= 1.05; + } - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } else { + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } else { /* Case 6, no information to guide us. */ - if (*ttype == -6) { - *g += (1. - *g) * .333; - } else if (*ttype == -18) { - *g = .083250000000000005; - } else { - *g = .25; - } - s = *g * *dmin__; - *ttype = -6; - } + if (*ttype == -6) { + *g += (1. - *g) * .333; + } else if (*ttype == -18) { + *g = .083250000000000005; + } else { + *g = .25; + } + s = *g * *dmin__; + *ttype = -6; + } } else if (*n0in == *n0 + 1) { /* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ - if (*dmin1 == *dn1 && *dmin2 == *dn2) { + if (*dmin1 == *dn1 && *dmin2 == *dn2) { /* Cases 7 and 8. */ - *ttype = -7; - s = *dmin1 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L60; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - a2 = b1; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (max(b1,a2) * 100. < b2) { - goto L60; - } + *ttype = -7; + s = *dmin1 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L60; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + a2 = b1; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (max(b1,a2) * 100. < b2) { + goto L60; + } /* L50: */ - } + } L60: - b2 = sqrt(b2 * 1.05); + b2 = sqrt(b2 * 1.05); /* Computing 2nd power */ - d__1 = b2; - a2 = *dmin1 / (d__1 * d__1 + 1.); - gap2 = *dmin2 * .5 - a2; - if (gap2 > 0. && gap2 > b2 * a2) { + d__1 = b2; + a2 = *dmin1 / (d__1 * d__1 + 1.); + gap2 = *dmin2 * .5 - a2; + if (gap2 > 0. && gap2 > b2 * a2) { /* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = max(d__1,d__2); - } else { + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = max(d__1,d__2); + } else { /* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = max(d__1,d__2); - *ttype = -8; - } - } else { + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = max(d__1,d__2); + *ttype = -8; + } + } else { /* Case 9. */ - s = *dmin1 * .25; - if (*dmin1 == *dn1) { - s = *dmin1 * .5; - } - *ttype = -9; - } + s = *dmin1 * .25; + if (*dmin1 == *dn1) { + s = *dmin1 * .5; + } + *ttype = -9; + } } else if (*n0in == *n0 + 2) { @@ -438,55 +438,55 @@ L60: /* Cases 10 and 11. */ - if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { - *ttype = -10; - s = *dmin2 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L80; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (b1 * 100. < b2) { - goto L80; - } + if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { + *ttype = -10; + s = *dmin2 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L80; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (b1 * 100. < b2) { + goto L80; + } /* L70: */ - } + } L80: - b2 = sqrt(b2 * 1.05); + b2 = sqrt(b2 * 1.05); /* Computing 2nd power */ - d__1 = b2; - a2 = *dmin2 / (d__1 * d__1 + 1.); - gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ - nn - 9]) - a2; - if (gap2 > 0. && gap2 > b2 * a2) { + d__1 = b2; + a2 = *dmin2 / (d__1 * d__1 + 1.); + gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ + nn - 9]) - a2; + if (gap2 > 0. && gap2 > b2 * a2) { /* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = max(d__1,d__2); - } else { + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = max(d__1,d__2); + } else { /* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = max(d__1,d__2); - } - } else { - s = *dmin2 * .25; - *ttype = -11; - } + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = max(d__1,d__2); + } + } else { + s = *dmin2 * .25; + *ttype = -11; + } } else if (*n0in > *n0 + 2) { /* Case 12, more than two eigenvalues deflated. No information. */ - s = 0.; - *ttype = -12; + s = 0.; + *ttype = -12; } *tau = s; @@ -497,5 +497,5 @@ L80: } /* dlasq4_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq5.cpp b/lib/linalg/dlasq5.cpp index 13ae0ed20c..a7cd93932f 100644 --- a/lib/linalg/dlasq5.cpp +++ b/lib/linalg/dlasq5.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq5.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -159,10 +159,10 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *tau, doublereal *sigma, doublereal *dmin__, - doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal * - dnm1, doublereal *dnm2, logical *ieee, doublereal *eps) +/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__, + integer *pp, doublereal *tau, doublereal *sigma, doublereal *dmin__, + doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal * + dnm1, doublereal *dnm2, logical *ieee, doublereal *eps) { /* System generated locals */ integer i__1; @@ -198,273 +198,273 @@ f"> */ /* Function Body */ if (*n0 - *i0 - 1 <= 0) { - return 0; + return 0; } dthresh = *eps * (*sigma + *tau); if (*tau < dthresh * .5) { - *tau = 0.; + *tau = 0.; } if (*tau != 0.) { - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4] - *tau; - *dmin__ = d__; - *dmin1 = -z__[j4]; + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; - if (*ieee) { + if (*ieee) { /* Code for IEEE arithmetic. */ - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - temp = z__[j4 + 1] / z__[j4 - 2]; - d__ = d__ * temp - *tau; - *dmin__ = min(*dmin__,d__); - z__[j4] = z__[j4 - 1] * temp; + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + *dmin__ = min(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; /* Computing MIN */ - d__1 = z__[j4]; - emin = min(d__1,emin); + d__1 = z__[j4]; + emin = min(d__1,emin); /* L10: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - temp = z__[j4 + 2] / z__[j4 - 3]; - d__ = d__ * temp - *tau; - *dmin__ = min(*dmin__,d__); - z__[j4 - 1] = z__[j4] * temp; + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + *dmin__ = min(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; /* Computing MIN */ - d__1 = z__[j4 - 1]; - emin = min(d__1,emin); + d__1 = z__[j4 - 1]; + emin = min(d__1,emin); /* L20: */ - } - } + } + } /* Unroll last two steps. */ - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dnm1); + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__,*dnm1); - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dn); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__,*dn); - } else { + } else { /* Code for non IEEE arithmetic. */ - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (d__ < 0.) { - return 0; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,d__); + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1,d__2); /* L30: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (d__ < 0.) { - return 0; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; - } - *dmin__ = min(*dmin__,d__); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1,d__2); /* L40: */ - } - } + } + } /* Unroll last two steps. */ - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (*dnm2 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dnm1); + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__,*dnm1); - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (*dnm1 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dn); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__,*dn); - } + } } else { /* This is the version that sets d's to zero if they are small enough */ - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4] - *tau; - *dmin__ = d__; - *dmin1 = -z__[j4]; - if (*ieee) { + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + if (*ieee) { /* Code for IEEE arithmetic. */ - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - temp = z__[j4 + 1] / z__[j4 - 2]; - d__ = d__ * temp - *tau; - if (d__ < dthresh) { - d__ = 0.; - } - *dmin__ = min(*dmin__,d__); - z__[j4] = z__[j4 - 1] * temp; + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; /* Computing MIN */ - d__1 = z__[j4]; - emin = min(d__1,emin); + d__1 = z__[j4]; + emin = min(d__1,emin); /* L50: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - temp = z__[j4 + 2] / z__[j4 - 3]; - d__ = d__ * temp - *tau; - if (d__ < dthresh) { - d__ = 0.; - } - *dmin__ = min(*dmin__,d__); - z__[j4 - 1] = z__[j4] * temp; + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; /* Computing MIN */ - d__1 = z__[j4 - 1]; - emin = min(d__1,emin); + d__1 = z__[j4 - 1]; + emin = min(d__1,emin); /* L60: */ - } - } + } + } /* Unroll last two steps. */ - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dnm1); + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__,*dnm1); - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dn); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__,*dn); - } else { + } else { /* Code for non IEEE arithmetic. */ - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (d__ < 0.) { - return 0; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; - } - if (d__ < dthresh) { - d__ = 0.; - } - *dmin__ = min(*dmin__,d__); + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1,d__2); /* L70: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (d__ < 0.) { - return 0; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; - } - if (d__ < dthresh) { - d__ = 0.; - } - *dmin__ = min(*dmin__,d__); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1,d__2); /* L80: */ - } - } + } + } /* Unroll last two steps. */ - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (*dnm2 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dnm1); + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__,*dnm1); - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (*dnm1 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dn); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__,*dn); - } + } } z__[j4 + 2] = *dn; @@ -476,5 +476,5 @@ f"> */ } /* dlasq5_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasq6.cpp b/lib/linalg/dlasq6.cpp index b06e9ad028..96bda77630 100644 --- a/lib/linalg/dlasq6.cpp +++ b/lib/linalg/dlasq6.cpp @@ -1,13 +1,13 @@ /* fortran/dlasq6.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -134,9 +134,9 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, - doublereal *dn, doublereal *dnm1, doublereal *dnm2) +/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, + integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, + doublereal *dn, doublereal *dnm1, doublereal *dnm2) { /* System generated locals */ integer i__1; @@ -176,7 +176,7 @@ f"> */ /* Function Body */ if (*n0 - *i0 - 1 <= 0) { - return 0; + return 0; } safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); @@ -186,53 +186,53 @@ f"> */ *dmin__ = d__; if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - d__ = z__[j4 + 1]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 - - 2] < z__[j4 + 1]) { - temp = z__[j4 + 1] / z__[j4 - 2]; - z__[j4] = z__[j4 - 1] * temp; - d__ *= temp; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); - } - *dmin__ = min(*dmin__,d__); + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + d__ = z__[j4 + 1]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 + - 2] < z__[j4 + 1]) { + temp = z__[j4 + 1] / z__[j4 - 2]; + z__[j4] = z__[j4 - 1] * temp; + d__ *= temp; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1,d__2); /* L10: */ - } + } } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (z__[j4 - 3] == 0.) { - z__[j4 - 1] = 0.; - d__ = z__[j4 + 2]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 - - 3] < z__[j4 + 2]) { - temp = z__[j4 + 2] / z__[j4 - 3]; - z__[j4 - 1] = z__[j4] * temp; - d__ *= temp; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); - } - *dmin__ = min(*dmin__,d__); + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (z__[j4 - 3] == 0.) { + z__[j4 - 1] = 0.; + d__ = z__[j4 + 2]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 + - 3] < z__[j4 + 2]) { + temp = z__[j4 + 2] / z__[j4 - 3]; + z__[j4 - 1] = z__[j4] * temp; + d__ *= temp; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); + } + *dmin__ = min(*dmin__,d__); /* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = min(d__1,d__2); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1,d__2); /* L20: */ - } + } } /* Unroll last two steps. */ @@ -243,18 +243,18 @@ f"> */ j4p2 = j4 + (*pp << 1) - 1; z__[j4 - 2] = *dnm2 + z__[j4p2]; if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dnm1 = z__[j4p2 + 2]; - *dmin__ = *dnm1; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dnm1 = *dnm2 * temp; + z__[j4] = 0.; + *dnm1 = z__[j4p2 + 2]; + *dmin__ = *dnm1; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dnm1 = *dnm2 * temp; } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); } *dmin__ = min(*dmin__,*dnm1); @@ -263,18 +263,18 @@ f"> */ j4p2 = j4 + (*pp << 1) - 1; z__[j4 - 2] = *dnm1 + z__[j4p2]; if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dn = z__[j4p2 + 2]; - *dmin__ = *dn; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dn = *dnm1 * temp; + z__[j4] = 0.; + *dn = z__[j4p2 + 2]; + *dmin__ = *dn; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dn = *dnm1 * temp; } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); } *dmin__ = min(*dmin__,*dn); @@ -287,5 +287,5 @@ f"> */ } /* dlasq6_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasr.cpp b/lib/linalg/dlasr.cpp index c4de2f85a9..5baf2cd50c 100644 --- a/lib/linalg/dlasr.cpp +++ b/lib/linalg/dlasr.cpp @@ -1,13 +1,13 @@ /* fortran/dlasr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -216,8 +216,8 @@ extern "C" { /* ===================================================================== */ /* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, doublereal *c__, doublereal *s, doublereal *a, integer * - lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len) + integer *n, doublereal *c__, doublereal *s, doublereal *a, integer * + lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -265,264 +265,264 @@ extern "C" { /* Function Body */ info = 0; if (! (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", ( - ftnlen)1, (ftnlen)1))) { - info = 1; - } else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot, - (char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, ( - ftnlen)1))) { - info = 2; - } else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct, - (char *)"B", (ftnlen)1, (ftnlen)1))) { - info = 3; + ftnlen)1, (ftnlen)1))) { + info = 1; + } else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot, + (char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, ( + ftnlen)1))) { + info = 2; + } else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct, + (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 3; } else if (*m < 0) { - info = 4; + info = 4; } else if (*n < 0) { - info = 5; + info = 5; } else if (*lda < max(1,*m)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"DLASR ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DLASR ", &info, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form P * A */ - if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + 1 + i__ * a_dim1]; - a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * - a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j - + i__ * a_dim1]; + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; /* L10: */ - } - } + } + } /* L20: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + 1 + i__ * a_dim1]; - a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * - a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j - + i__ * a_dim1]; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; /* L30: */ - } - } + } + } /* L40: */ - } - } - } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ - i__ * a_dim1 + 1]; - a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ - i__ * a_dim1 + 1]; + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; /* L50: */ - } - } + } + } /* L60: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ - i__ * a_dim1 + 1]; - a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ - i__ * a_dim1 + 1]; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; /* L70: */ - } - } + } + } /* L80: */ - } - } - } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] - + ctemp * temp; - a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * - a_dim1] - stemp * temp; + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; /* L90: */ - } - } + } + } /* L100: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] - + ctemp * temp; - a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * - a_dim1] - stemp * temp; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; /* L110: */ - } - } + } + } /* L120: */ - } - } - } + } + } + } } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form A * P**T */ - if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + (j + 1) * a_dim1]; - a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * - a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ - i__ + j * a_dim1]; + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; /* L130: */ - } - } + } + } /* L140: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + (j + 1) * a_dim1]; - a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * - a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ - i__ + j * a_dim1]; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; /* L150: */ - } - } + } + } /* L160: */ - } - } - } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ - i__ + a_dim1]; - a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + - a_dim1]; + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; /* L170: */ - } - } + } + } /* L180: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ - i__ + a_dim1]; - a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + - a_dim1]; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; /* L190: */ - } - } + } + } /* L200: */ - } - } - } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] - + ctemp * temp; - a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * - a_dim1] - stemp * temp; + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; /* L210: */ - } - } + } + } /* L220: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] - + ctemp * temp; - a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * - a_dim1] - stemp * temp; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; /* L230: */ - } - } + } + } /* L240: */ - } - } - } + } + } + } } return 0; @@ -532,5 +532,5 @@ extern "C" { } /* dlasr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasrt.cpp b/lib/linalg/dlasrt.cpp index 8c0eec5f2e..a796f6e568 100644 --- a/lib/linalg/dlasrt.cpp +++ b/lib/linalg/dlasrt.cpp @@ -1,13 +1,13 @@ /* fortran/dlasrt.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -105,7 +105,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer * - info, ftnlen id_len) + info, ftnlen id_len) { /* System generated locals */ integer i__1, i__2; @@ -117,7 +117,7 @@ f"> */ doublereal tmp; integer endd; extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer stack[64] /* was [2][32] */; + integer stack[64] /* was [2][32] */; doublereal dmnmx; integer start; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -156,25 +156,25 @@ f"> */ *info = 0; dir = -1; if (lsame_(id, (char *)"D", (ftnlen)1, (ftnlen)1)) { - dir = 0; + dir = 0; } else if (lsame_(id, (char *)"I", (ftnlen)1, (ftnlen)1)) { - dir = 1; + dir = 1; } if (dir == -1) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLASRT", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLASRT", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 1) { - return 0; + return 0; } stkpnt = 1; @@ -188,49 +188,49 @@ L10: /* Do Insertion sort on D( START:ENDD ) */ - if (dir == 0) { + if (dir == 0) { /* Sort into decreasing order */ - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] > d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L30; - } + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] > d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L30; + } /* L20: */ - } + } L30: - ; - } + ; + } - } else { + } else { /* Sort into increasing order */ - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] < d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L50; - } + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] < d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L50; + } /* L40: */ - } + } L50: - ; - } + ; + } - } + } } else if (endd - start > 20) { @@ -238,108 +238,108 @@ L50: /* Choose partition entry as median of 3 */ - d1 = d__[start]; - d2 = d__[endd]; - i__ = (start + endd) / 2; - d3 = d__[i__]; - if (d1 < d2) { - if (d3 < d1) { - dmnmx = d1; - } else if (d3 < d2) { - dmnmx = d3; - } else { - dmnmx = d2; - } - } else { - if (d3 < d2) { - dmnmx = d2; - } else if (d3 < d1) { - dmnmx = d3; - } else { - dmnmx = d1; - } - } + d1 = d__[start]; + d2 = d__[endd]; + i__ = (start + endd) / 2; + d3 = d__[i__]; + if (d1 < d2) { + if (d3 < d1) { + dmnmx = d1; + } else if (d3 < d2) { + dmnmx = d3; + } else { + dmnmx = d2; + } + } else { + if (d3 < d2) { + dmnmx = d2; + } else if (d3 < d1) { + dmnmx = d3; + } else { + dmnmx = d1; + } + } - if (dir == 0) { + if (dir == 0) { /* Sort into decreasing order */ - i__ = start - 1; - j = endd + 1; + i__ = start - 1; + j = endd + 1; L60: L70: - --j; - if (d__[j] < dmnmx) { - goto L70; - } + --j; + if (d__[j] < dmnmx) { + goto L70; + } L80: - ++i__; - if (d__[i__] > dmnmx) { - goto L80; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L60; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } else { + ++i__; + if (d__[i__] > dmnmx) { + goto L80; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L60; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } else { /* Sort into increasing order */ - i__ = start - 1; - j = endd + 1; + i__ = start - 1; + j = endd + 1; L90: L100: - --j; - if (d__[j] > dmnmx) { - goto L100; - } + --j; + if (d__[j] > dmnmx) { + goto L100; + } L110: - ++i__; - if (d__[i__] < dmnmx) { - goto L110; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L90; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } + ++i__; + if (d__[i__] < dmnmx) { + goto L110; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L90; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } } if (stkpnt > 0) { - goto L10; + goto L10; } return 0; @@ -348,5 +348,5 @@ L110: } /* dlasrt_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlassq.cpp b/lib/linalg/dlassq.cpp index fe346d2247..76391a54f9 100644 --- a/lib/linalg/dlassq.cpp +++ b/lib/linalg/dlassq.cpp @@ -1,13 +1,13 @@ /* fortran/dlassq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -121,8 +121,8 @@ f"> */ /* > \ingroup OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, - doublereal *scale, doublereal *sumsq) +/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, + doublereal *scale, doublereal *sumsq) { /* System generated locals */ integer i__1, i__2; @@ -161,24 +161,24 @@ f"> */ /* Function Body */ if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - absxi = (d__1 = x[ix], abs(d__1)); - if (absxi > 0. || disnan_(&absxi)) { - if (*scale < absxi) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + absxi = (d__1 = x[ix], abs(d__1)); + if (absxi > 0. || disnan_(&absxi)) { + if (*scale < absxi) { /* Computing 2nd power */ - d__1 = *scale / absxi; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = absxi; - } else { + d__1 = *scale / absxi; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = absxi; + } else { /* Computing 2nd power */ - d__1 = absxi / *scale; - *sumsq += d__1 * d__1; - } - } + d__1 = absxi / *scale; + *sumsq += d__1 * d__1; + } + } /* L10: */ - } + } } return 0; @@ -187,5 +187,5 @@ f"> */ } /* dlassq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlasv2.cpp b/lib/linalg/dlasv2.cpp index 4667b941d4..7bab630b39 100644 --- a/lib/linalg/dlasv2.cpp +++ b/lib/linalg/dlasv2.cpp @@ -1,13 +1,13 @@ /* fortran/dlasv2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -159,9 +159,9 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * - csr, doublereal *snl, doublereal *csl) +/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, + doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * + csr, doublereal *snl, doublereal *csl) { /* System generated locals */ doublereal d__1; @@ -170,8 +170,8 @@ f"> */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ - doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, - crt, slt, srt; + doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, + crt, slt, srt; integer pmax; doublereal temp; logical swap; @@ -212,13 +212,13 @@ f"> */ pmax = 1; swap = ha > fa; if (swap) { - pmax = 3; - temp = ft; - ft = ht; - ht = temp; - temp = fa; - fa = ha; - ha = temp; + pmax = 3; + temp = ft; + ft = ht; + ht = temp; + temp = fa; + fa = ha; + ha = temp; /* Now FA .ge. HA */ @@ -229,118 +229,118 @@ f"> */ /* Diagonal matrix */ - *ssmin = ha; - *ssmax = fa; - clt = 1.; - crt = 1.; - slt = 0.; - srt = 0.; + *ssmin = ha; + *ssmax = fa; + clt = 1.; + crt = 1.; + slt = 0.; + srt = 0.; } else { - gasmal = TRUE_; - if (ga > fa) { - pmax = 2; - if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) { + gasmal = TRUE_; + if (ga > fa) { + pmax = 2; + if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) { /* Case of very large GA */ - gasmal = FALSE_; - *ssmax = ga; - if (ha > 1.) { - *ssmin = fa / (ga / ha); - } else { - *ssmin = fa / ga * ha; - } - clt = 1.; - slt = ht / gt; - srt = 1.; - crt = ft / gt; - } - } - if (gasmal) { + gasmal = FALSE_; + *ssmax = ga; + if (ha > 1.) { + *ssmin = fa / (ga / ha); + } else { + *ssmin = fa / ga * ha; + } + clt = 1.; + slt = ht / gt; + srt = 1.; + crt = ft / gt; + } + } + if (gasmal) { /* Normal case */ - d__ = fa - ha; - if (d__ == fa) { + d__ = fa - ha; + if (d__ == fa) { /* Copes with infinite F or H */ - l = 1.; - } else { - l = d__ / fa; - } + l = 1.; + } else { + l = d__ / fa; + } /* Note that 0 .le. L .le. 1 */ - m = gt / ft; + m = gt / ft; /* Note that abs(M) .le. 1/macheps */ - t = 2. - l; + t = 2. - l; /* Note that T .ge. 1 */ - mm = m * m; - tt = t * t; - s = sqrt(tt + mm); + mm = m * m; + tt = t * t; + s = sqrt(tt + mm); /* Note that 1 .le. S .le. 1 + 1/macheps */ - if (l == 0.) { - r__ = abs(m); - } else { - r__ = sqrt(l * l + mm); - } + if (l == 0.) { + r__ = abs(m); + } else { + r__ = sqrt(l * l + mm); + } /* Note that 0 .le. R .le. 1 + 1/macheps */ - a = (s + r__) * .5; + a = (s + r__) * .5; /* Note that 1 .le. A .le. 1 + abs(M) */ - *ssmin = ha / a; - *ssmax = fa * a; - if (mm == 0.) { + *ssmin = ha / a; + *ssmax = fa * a; + if (mm == 0.) { /* Note that M is very tiny */ - if (l == 0.) { - t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); - } else { - t = gt / d_sign(&d__, &ft) + m / t; - } - } else { - t = (m / (s + t) + m / (r__ + l)) * (a + 1.); - } - l = sqrt(t * t + 4.); - crt = 2. / l; - srt = t / l; - clt = (crt + srt * m) / a; - slt = ht / ft * srt / a; - } + if (l == 0.) { + t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); + } else { + t = gt / d_sign(&d__, &ft) + m / t; + } + } else { + t = (m / (s + t) + m / (r__ + l)) * (a + 1.); + } + l = sqrt(t * t + 4.); + crt = 2. / l; + srt = t / l; + clt = (crt + srt * m) / a; + slt = ht / ft * srt / a; + } } if (swap) { - *csl = srt; - *snl = crt; - *csr = slt; - *snr = clt; + *csl = srt; + *snl = crt; + *csr = slt; + *snr = clt; } else { - *csl = clt; - *snl = slt; - *csr = crt; - *snr = srt; + *csl = clt; + *snl = slt; + *csr = crt; + *snr = srt; } /* Correct signs of SSMAX and SSMIN */ if (pmax == 1) { - tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); + tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); } if (pmax == 2) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); + tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); } if (pmax == 3) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); + tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); } *ssmax = d_sign(ssmax, &tsign); d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); @@ -352,5 +352,5 @@ f"> */ } /* dlasv2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlaswp.cpp b/lib/linalg/dlaswp.cpp index db83b75947..05d911f30c 100644 --- a/lib/linalg/dlaswp.cpp +++ b/lib/linalg/dlaswp.cpp @@ -1,13 +1,13 @@ /* fortran/dlaswp.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -131,8 +131,8 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx) +/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer + *k1, integer *k2, integer *ipiv, integer *incx) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; @@ -168,63 +168,63 @@ f"> */ /* Function Body */ if (*incx > 0) { - ix0 = *k1; - i1 = *k1; - i2 = *k2; - inc = 1; + ix0 = *k1; + i1 = *k1; + i2 = *k2; + inc = 1; } else if (*incx < 0) { - ix0 = *k1 + (*k1 - *k2) * *incx; - i1 = *k2; - i2 = *k1; - inc = -1; + ix0 = *k1 + (*k1 - *k2) * *incx; + i1 = *k2; + i2 = *k1; + inc = -1; } else { - return 0; + return 0; } n32 = *n / 32 << 5; if (n32 != 0) { - i__1 = n32; - for (j = 1; j <= i__1; j += 32) { - ix = ix0; - i__2 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - ip = ipiv[ix]; - if (ip != i__) { - i__4 = j + 31; - for (k = j; k <= i__4; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; + i__1 = n32; + for (j = 1; j <= i__1; j += 32) { + ix = ix0; + i__2 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + ip = ipiv[ix]; + if (ip != i__) { + i__4 = j + 31; + for (k = j; k <= i__4; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; /* L10: */ - } - } - ix += *incx; + } + } + ix += *incx; /* L20: */ - } + } /* L30: */ - } + } } if (n32 != *n) { - ++n32; - ix = ix0; - i__1 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { - ip = ipiv[ix]; - if (ip != i__) { - i__2 = *n; - for (k = n32; k <= i__2; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; + ++n32; + ix = ix0; + i__1 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { + ip = ipiv[ix]; + if (ip != i__) { + i__2 = *n; + for (k = n32; k <= i__2; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; /* L40: */ - } - } - ix += *incx; + } + } + ix += *incx; /* L50: */ - } + } } return 0; @@ -234,5 +234,5 @@ f"> */ } /* dlaswp_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlatrd.cpp b/lib/linalg/dlatrd.cpp index b291e1adbf..74fc5fcc87 100644 --- a/lib/linalg/dlatrd.cpp +++ b/lib/linalg/dlatrd.cpp @@ -1,13 +1,13 @@ /* fortran/dlatrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -223,28 +223,28 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal * - a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, - integer *ldw, ftnlen uplo_len) + a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, + integer *ldw, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; /* Local variables */ integer i__, iw; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); doublereal alpha; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen), daxpy_(integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *), - dsymv_(char *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *, - doublereal *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen), daxpy_(integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *), + dsymv_(char *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen), dlarfg_(integer *, doublereal *, doublereal *, integer *, + doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -284,154 +284,154 @@ f"> */ /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { /* Reduce last NB columns of upper triangle */ - i__1 = *n - *nb + 1; - for (i__ = *n; i__ >= i__1; --i__) { - iw = i__ - *n + *nb; - if (i__ < *n) { + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { /* Update A(1:i,i) */ - i__2 = *n - i__; - dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & - c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); - i__2 = *n - i__; - dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); - } - if (i__ > 1) { + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & + c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b6, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); + } + if (i__ > 1) { /* Generate elementary reflector H(i) to annihilate */ /* A(1:i-2,i) */ - i__2 = i__ - 1; - dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + - 1], &c__1, &tau[i__ - 1]); - e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; - a[i__ - 1 + i__ * a_dim1] = 1.; + i__2 = i__ - 1; + dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + + 1], &c__1, &tau[i__ - 1]); + e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; + a[i__ - 1 + i__ * a_dim1] = 1.; /* Compute W(1:i-1,i) */ - i__2 = i__ - 1; - dsymv_((char *)"Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * - a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & - c__1, (ftnlen)5); - if (i__ < *n) { - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) - 9); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) - 12); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) - 9); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) - 12); - } - i__2 = i__ - 1; - dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], - &c__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = i__ - 1; - daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * - w_dim1 + 1], &c__1); - } + i__2 = i__ - 1; + dsymv_((char *)"Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * + a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & + c__1, (ftnlen)5); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) + 9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) + 12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, (ftnlen) + 9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, (ftnlen) + 12); + } + i__2 = i__ - 1; + dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], + &c__1, &a[i__ * a_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * + w_dim1 + 1], &c__1); + } /* L10: */ - } + } } else { /* Reduce first NB columns of lower triangle */ - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i:n,i) */ - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, - &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & - c__1, (ftnlen)12); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, - &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & - c__1, (ftnlen)12); - if (i__ < *n) { + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, + &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & + c__1, (ftnlen)12); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, + &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & + c__1, (ftnlen)12); + if (i__ < *n) { /* Generate elementary reflector H(i) to annihilate */ /* A(i+2:n,i) */ - i__2 = *n - i__; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + - i__ * a_dim1], &c__1, &tau[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + + i__ * a_dim1], &c__1, &tau[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; /* Compute W(i+1:n,i) */ - i__2 = *n - i__; - dsymv_((char *)"Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] - , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], - ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + - a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1, (ftnlen)9); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + - w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); - i__2 = *n - i__; - dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * - w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - } + i__2 = *n - i__; + dsymv_((char *)"Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] + , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], + ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__; + dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * + w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + } /* L20: */ - } + } } return 0; @@ -441,5 +441,5 @@ f"> */ } /* dlatrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dlatrs.cpp b/lib/linalg/dlatrs.cpp index 0b68eac917..fc97690682 100644 --- a/lib/linalg/dlatrs.cpp +++ b/lib/linalg/dlatrs.cpp @@ -1,13 +1,13 @@ /* fortran/dlatrs.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -20,7 +20,7 @@ extern "C" { static integer c__1 = 1; static doublereal c_b46 = .5; -/* > \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. +/* > \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. */ /* =========== DOCUMENTATION =========== */ @@ -260,9 +260,9 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, doublereal *a, integer *lda, doublereal *x, - doublereal *scale, doublereal *cnorm, integer *info, ftnlen uplo_len, - ftnlen trans_len, ftnlen diag_len, ftnlen normin_len) + normin, integer *n, doublereal *a, integer *lda, doublereal *x, + doublereal *scale, doublereal *cnorm, integer *info, ftnlen uplo_len, + ftnlen trans_len, ftnlen diag_len, ftnlen normin_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -272,25 +272,25 @@ f"> */ integer i__, j; doublereal xj, rec, tjj; integer jinc; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); doublereal xbnd; integer imax; doublereal tmax, tjjs, xmax, grow, sumj; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal tscal, uscal; extern doublereal dasum_(integer *, doublereal *, integer *); integer jlast; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); logical upper; - extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen); - extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *, ftnlen); + extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen); + extern doublereal dlamch_(char *, ftnlen), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, ftnlen); extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal bignum; @@ -339,65 +339,65 @@ f"> */ /* Test the input parameters. */ if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! - lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -1; + } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && ! + lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -2; } else if (! nounit && ! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) { - *info = -3; + *info = -3; } else if (! lsame_(normin, (char *)"Y", (ftnlen)1, (ftnlen)1) && ! lsame_(normin, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - *info = -4; + (char *)"N", (ftnlen)1, (ftnlen)1)) { + *info = -4; } else if (*n < 0) { - *info = -5; + *info = -5; } else if (*lda < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DLATRS", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DLATRS", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ *scale = 1.; if (*n == 0) { - return 0; + return 0; } /* Determine machine dependent parameters to control overflow. */ smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12) / dlamch_((char *)"Precision", ( - ftnlen)9); + ftnlen)9); bignum = 1. / smlnum; if (lsame_(normin, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Compute the 1-norm of each column, not including the diagonal. */ - if (upper) { + if (upper) { /* A is upper triangular. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); /* L10: */ - } - } else { + } + } else { /* A is lower triangular. */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); /* L20: */ - } - cnorm[*n] = 0.; - } + } + cnorm[*n] = 0.; + } } /* Scale the column norms by TSCAL if the maximum element in CNORM is */ @@ -406,81 +406,81 @@ f"> */ imax = idamax_(n, &cnorm[1], &c__1); tmax = cnorm[imax]; if (tmax <= bignum) { - tscal = 1.; + tscal = 1.; } else { /* Avoid NaN generation if entries in CNORM exceed the */ /* overflow threshold */ - if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { + if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { /* Case 1: All entries in CNORM are valid floating-point numbers */ - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } else { + tscal = 1. / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } else { /* Case 2: At least one column norm of A cannot be represented */ /* as floating-point number. Find the offdiagonal entry A( I, J ) */ /* with the largest absolute value. If this entry is not +/- Infinity, */ /* use this value as TSCAL. */ - tmax = 0.; - if (upper) { + tmax = 0.; + if (upper) { /* A is upper triangular. */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { /* Computing MAX */ - i__2 = j - 1; - d__1 = dlange_((char *)"M", &i__2, &c__1, &a[j * a_dim1 + 1], & - c__1, &sumj, (ftnlen)1); - tmax = max(d__1,tmax); - } - } else { + i__2 = j - 1; + d__1 = dlange_((char *)"M", &i__2, &c__1, &a[j * a_dim1 + 1], & + c__1, &sumj, (ftnlen)1); + tmax = max(d__1,tmax); + } + } else { /* A is lower triangular. */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { /* Computing MAX */ - i__2 = *n - j; - d__1 = dlange_((char *)"M", &i__2, &c__1, &a[j + 1 + j * a_dim1], - &c__1, &sumj, (ftnlen)1); - tmax = max(d__1,tmax); - } - } + i__2 = *n - j; + d__1 = dlange_((char *)"M", &i__2, &c__1, &a[j + 1 + j * a_dim1], + &c__1, &sumj, (ftnlen)1); + tmax = max(d__1,tmax); + } + } - if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { - tscal = 1. / (smlnum * tmax); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (cnorm[j] <= dlamch_((char *)"Overflow", (ftnlen)8)) { - cnorm[j] *= tscal; - } else { + if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { + tscal = 1. / (smlnum * tmax); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (cnorm[j] <= dlamch_((char *)"Overflow", (ftnlen)8)) { + cnorm[j] *= tscal; + } else { /* Recompute the 1-norm without introducing Infinity */ /* in the summation */ - cnorm[j] = 0.; - if (upper) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - cnorm[j] += tscal * (d__1 = a[i__ + j * - a_dim1], abs(d__1)); - } - } else { - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - cnorm[j] += tscal * (d__1 = a[i__ + j * - a_dim1], abs(d__1)); - } - } - } - } - } else { + cnorm[j] = 0.; + if (upper) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + cnorm[j] += tscal * (d__1 = a[i__ + j * + a_dim1], abs(d__1)); + } + } else { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + cnorm[j] += tscal * (d__1 = a[i__ + j * + a_dim1], abs(d__1)); + } + } + } + } + } else { /* At least one entry of A is not a valid floating-point entry. */ /* Rely on TRSV to propagate Inf and NaN. */ - dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, - (ftnlen)1, (ftnlen)1, (ftnlen)1); - return 0; - } - } + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + return 0; + } + } } /* Compute a bound on the computed solution vector to see if the */ @@ -493,170 +493,170 @@ f"> */ /* Compute the growth in A * x = b. */ - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - } + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } - if (tscal != 1.) { - grow = 0.; - goto L50; - } + if (tscal != 1.) { + grow = 0.; + goto L50; + } - if (nounit) { + 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 = 1. / 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) { + grow = 1. / 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 L50; - } + if (grow <= smlnum) { + goto L50; + } /* M(j) = G(j-1) / abs(A(j,j)) */ - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); /* Computing MIN */ - d__1 = xbnd, d__2 = min(1.,tjj) * grow; - xbnd = min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { + d__1 = xbnd, d__2 = min(1.,tjj) * grow; + xbnd = min(d__1,d__2); + if (tjj + cnorm[j] >= smlnum) { /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - grow *= tjj / (tjj + cnorm[j]); - } else { + grow *= tjj / (tjj + cnorm[j]); + } else { /* G(j) could overflow, set GROW to 0. */ - grow = 0.; - } + grow = 0.; + } /* L30: */ - } - grow = xbnd; - } else { + } + 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 = 1. / 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) { + d__1 = 1., d__2 = 1. / 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 L50; - } + if (grow <= smlnum) { + goto L50; + } /* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - grow *= 1. / (cnorm[j] + 1.); + grow *= 1. / (cnorm[j] + 1.); /* L40: */ - } - } + } + } L50: - ; + ; } else { /* Compute the growth in A**T * x = b. */ - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - } + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } - if (tscal != 1.) { - grow = 0.; - goto L80; - } + if (tscal != 1.) { + grow = 0.; + goto L80; + } - if (nounit) { + 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 = 1. / 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) { + grow = 1. / 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 L80; - } + if (grow <= smlnum) { + goto L80; + } /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - xj = cnorm[j] + 1.; + xj = cnorm[j] + 1.; /* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = min(d__1,d__2); + d__1 = grow, d__2 = xbnd / xj; + grow = min(d__1,d__2); /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } /* L60: */ - } - grow = min(grow,xbnd); - } else { + } + 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 = 1. / 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) { + d__1 = 1., d__2 = 1. / 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 L80; - } + if (grow <= smlnum) { + goto L80; + } /* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - xj = cnorm[j] + 1.; - grow /= xj; + xj = cnorm[j] + 1.; + grow /= xj; /* L70: */ - } - } + } + } L80: - ; + ; } if (grow * tscal > smlnum) { @@ -664,313 +664,313 @@ L80: /* Use the Level 2 BLAS solve if the reciprocal of the bound on */ /* elements of X is not too small. */ - dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); } else { /* Use a Level 1 BLAS solve, scaling intermediate results. */ - if (xmax > bignum) { + if (xmax > bignum) { /* Scale X so that its components are less than or equal to */ /* BIGNUM in absolute value. */ - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } + *scale = bignum / xmax; + dscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } - if (notran) { + 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) { + 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. */ - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L100; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ - if (tjj < 1.) { - if (xj > tjj * bignum) { + if (tjj < 1.) { + if (xj > tjj * bignum) { /* Scale x by 1/b(j). */ - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ - if (xj > tjj * bignum) { + 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.) { + 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]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { + rec /= cnorm[j]; + } + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } 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__) { - x[i__] = 0.; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; /* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } + } + x[j] = 1.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } L100: /* 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) { + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { /* Scale x by 1/(2*abs(x(j))). */ - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { + rec *= .5; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { /* Scale x by 1/2. */ - dscal_(n, &c_b46, &x[1], &c__1); - *scale *= .5; - } + dscal_(n, &c_b46, &x[1], &c__1); + *scale *= .5; + } - if (upper) { - if (j > 1) { + 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; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } else { - if (j < *n) { + i__3 = j - 1; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + i__3 = j - 1; + i__ = idamax_(&i__3, &x[1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } 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; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & - x[j + 1], &c__1); - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } + i__3 = *n - j; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + i__3 = *n - j; + i__ = j + idamax_(&i__3, &x[j + 1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } /* L110: */ - } + } - } else { + } else { /* 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) { + 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 */ - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { + xj = (d__1 = x[j], abs(d__1)); + uscal = tscal; + 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) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { + rec *= .5; + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + 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); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } + d__1 = 1., d__2 = rec * tjj; + rec = min(d__1,d__2); + uscal /= tjjs; + } + if (rec < 1.) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } - sumj = 0.; - if (uscal == 1.) { + sumj = 0.; + if (uscal == 1.) { /* If the scaling needed for A in the dot product is 1, */ /* call DDOT to perform the dot product. */ - if (upper) { - i__3 = j - 1; - sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - } else if (j < *n) { - i__3 = *n - j; - sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ - j + 1], &c__1); - } - } else { + if (upper) { + i__3 = j - 1; + sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ + j + 1], &c__1); + } + } else { /* Otherwise, use in-line code for the dot product. */ - if (upper) { - i__3 = j - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; /* L120: */ - } - } else if (j < *n) { - i__3 = *n; - for (i__ = j + 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; /* L130: */ - } - } - } + } + } + } - if (uscal == tscal) { + if (uscal == tscal) { /* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } + x[j] -= sumj; + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L150; + } + } /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - tjj = abs(tjjs); - if (tjj > smlnum) { + tjj = abs(tjjs); + if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ - if (tjj < 1.) { - if (xj > tjj * bignum) { + if (tjj < 1.) { + if (xj > tjj * bignum) { /* Scale X by 1/abs(x(j)). */ - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ - if (xj > tjj * bignum) { + if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { + rec = tjj * bignum / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } 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__) { - x[i__] = 0.; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; /* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } + } + x[j] = 1.; + *scale = 0.; + xmax = 0.; + } L150: - ; - } else { + ; + } else { /* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ /* product has already been divided by 1/A(j,j). */ - x[j] = x[j] / tjjs - sumj; - } + x[j] = x[j] / tjjs - sumj; + } /* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = max(d__2,d__3); + d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); + xmax = max(d__2,d__3); /* L160: */ - } - } - *scale /= tscal; + } + } + *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); + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); } return 0; @@ -980,5 +980,5 @@ L150: } /* dlatrs_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dnrm2.cpp b/lib/linalg/dnrm2.cpp index 6ebf2d935e..dc2a59dfbd 100644 --- a/lib/linalg/dnrm2.cpp +++ b/lib/linalg/dnrm2.cpp @@ -1,13 +1,13 @@ /* fortran/dnrm2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -126,35 +126,35 @@ doublereal dnrm2_(integer *n, doublereal *x, integer *incx) /* Function Body */ if (*n < 1 || *incx < 1) { - norm = 0.; + norm = 0.; } else if (*n == 1) { - norm = abs(x[1]); + norm = abs(x[1]); } else { - scale = 0.; - ssq = 1.; + scale = 0.; + ssq = 1.; /* The following loop is equivalent to this call to the LAPACK */ /* auxiliary routine: */ /* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (scale < absxi) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (scale < absxi) { /* Computing 2nd power */ - d__1 = scale / absxi; - ssq = ssq * (d__1 * d__1) + 1.; - scale = absxi; - } else { + d__1 = scale / absxi; + ssq = ssq * (d__1 * d__1) + 1.; + scale = absxi; + } else { /* Computing 2nd power */ - d__1 = absxi / scale; - ssq += d__1 * d__1; - } - } + d__1 = absxi / scale; + ssq += d__1 * d__1; + } + } /* L10: */ - } - norm = scale * sqrt(ssq); + } + norm = scale * sqrt(ssq); } ret_val = norm; @@ -165,5 +165,5 @@ doublereal dnrm2_(integer *n, doublereal *x, integer *incx) } /* dnrm2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorg2l.cpp b/lib/linalg/dorg2l.cpp index 5705f3b630..a028102645 100644 --- a/lib/linalg/dorg2l.cpp +++ b/lib/linalg/dorg2l.cpp @@ -1,13 +1,13 @@ /* fortran/dorg2l.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -136,7 +136,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -144,10 +144,10 @@ f"> */ /* Local variables */ integer i__, j, l, ii; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dlarf_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + ftnlen), xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -183,62 +183,62 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORG2L", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORG2L", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } /* Initialise columns 1:n-k to columns of the unit matrix */ i__1 = *n - *k; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; /* L10: */ - } - a[*m - *n + j + j * a_dim1] = 1.; + } + a[*m - *n + j + j * a_dim1] = 1.; /* L20: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - ii = *n - *k + i__; + ii = *n - *k + i__; /* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ - a[*m - *n + ii + ii * a_dim1] = 1.; - i__2 = *m - *n + ii; - i__3 = ii - 1; - dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & - a[a_offset], lda, &work[1], (ftnlen)4); - i__2 = *m - *n + ii - 1; - d__1 = -tau[i__]; - dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); - a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; + a[*m - *n + ii + ii * a_dim1] = 1.; + i__2 = *m - *n + ii; + i__3 = ii - 1; + dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & + a[a_offset], lda, &work[1], (ftnlen)4); + i__2 = *m - *n + ii - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); + a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; /* Set A(m-k+i+1:m,n-k+i) to zero */ - i__2 = *m; - for (l = *m - *n + ii + 1; l <= i__2; ++l) { - a[l + ii * a_dim1] = 0.; + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + a[l + ii * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -248,5 +248,5 @@ f"> */ } /* dorg2l_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorg2r.cpp b/lib/linalg/dorg2r.cpp index 90ebed3963..f6d897beb6 100644 --- a/lib/linalg/dorg2r.cpp +++ b/lib/linalg/dorg2r.cpp @@ -1,13 +1,13 @@ /* fortran/dorg2r.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -136,7 +136,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -144,10 +144,10 @@ f"> */ /* Local variables */ integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dlarf_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + ftnlen), xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -183,36 +183,36 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORG2R", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORG2R", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } /* Initialise columns k+1:n to columns of the unit matrix */ i__1 = *n; for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; /* L10: */ - } - a[j + j * a_dim1] = 1.; + } + a[j + j * a_dim1] = 1.; /* L20: */ } @@ -220,28 +220,28 @@ f"> */ /* Apply H(i) to A(i:m,i:n) from the left */ - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - dlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( - ftnlen)4); - } - if (i__ < *m) { - i__1 = *m - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + dlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( + ftnlen)4); + } + if (i__ < *m) { + i__1 = *m - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; /* Set A(1:i-1,i) to zero */ - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[l + i__ * a_dim1] = 0.; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[l + i__ * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -251,5 +251,5 @@ f"> */ } /* dorg2r_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorgbr.cpp b/lib/linalg/dorgbr.cpp index 4991344c01..a55e8aeca0 100644 --- a/lib/linalg/dorgbr.cpp +++ b/lib/linalg/dorgbr.cpp @@ -1,13 +1,13 @@ /* fortran/dorgbr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -177,9 +177,9 @@ f"> */ /* > \ingroup doubleGBcomputational */ /* ===================================================================== */ -/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info, ftnlen vect_len) +/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, + doublereal *a, integer *lda, doublereal *tau, doublereal *work, + integer *lwork, integer *info, ftnlen vect_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -190,10 +190,10 @@ f"> */ integer iinfo; logical wantq; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dorglq_( - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), dorgqr_( - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *); + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), dorgqr_( + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); integer lwkopt; logical lquery; @@ -236,67 +236,67 @@ f"> */ mn = min(*m,*n); lquery = *lwork == -1; if (! wantq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*m < 0) { - *info = -2; + *info = -2; } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( - *m > *n || *m < min(*n,*k))) { - *info = -3; + *m > *n || *m < min(*n,*k))) { + *info = -3; } else if (*k < 0) { - *info = -4; + *info = -4; } else if (*lda < max(1,*m)) { - *info = -6; + *info = -6; } else if (*lwork < max(1,mn) && ! lquery) { - *info = -9; + *info = -9; } if (*info == 0) { - work[1] = 1.; - if (wantq) { - if (*m >= *k) { - dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, - &iinfo); - } else { - if (*m > 1) { - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & - work[1], &c_n1, &iinfo); - } - } - } else { - if (*k < *n) { - dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, - &iinfo); - } else { - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & - work[1], &c_n1, &iinfo); - } - } - } - lwkopt = (integer) work[1]; - lwkopt = max(lwkopt,mn); + work[1] = 1.; + if (wantq) { + if (*m >= *k) { + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*m > 1) { + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & + work[1], &c_n1, &iinfo); + } + } + } else { + if (*k < *n) { + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & + work[1], &c_n1, &iinfo); + } + } + } + lwkopt = (integer) work[1]; + lwkopt = max(lwkopt,mn); } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGBR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGBR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - work[1] = (doublereal) lwkopt; - return 0; + work[1] = (doublereal) lwkopt; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } if (wantq) { @@ -304,14 +304,14 @@ f"> */ /* Form Q, determined by a call to DGEBRD to reduce an m-by-k */ /* matrix */ - if (*m >= *k) { + if (*m >= *k) { /* If m >= k, assume m >= n >= k */ - dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); - } else { + } else { /* If m < k, assume m = n */ @@ -319,45 +319,45 @@ f"> */ /* column to the right, and set the first row and column of Q */ /* to those of the unit matrix */ - for (j = *m; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.; - i__1 = *m; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; + for (j = *m; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *m; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; /* L10: */ - } + } /* L20: */ - } - a[a_dim1 + 1] = 1.; - i__1 = *m; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; + } + a[a_dim1 + 1] = 1.; + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; /* L30: */ - } - if (*m > 1) { + } + if (*m > 1) { /* Form Q(2:m,2:m) */ - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } } else { /* Form P**T, determined by a call to DGEBRD to reduce a k-by-n */ /* matrix */ - if (*k < *n) { + if (*k < *n) { /* If k < n, assume k <= m <= n */ - dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); - } else { + } else { /* If k >= n, assume m = n */ @@ -365,32 +365,32 @@ f"> */ /* row downward, and set the first row and column of P**T to */ /* those of the unit matrix */ - a[a_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; /* L40: */ - } - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - for (i__ = j - 1; i__ >= 2; --i__) { - a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; + } + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + for (i__ = j - 1; i__ >= 2; --i__) { + a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; /* L50: */ - } - a[j * a_dim1 + 1] = 0.; + } + a[j * a_dim1 + 1] = 0.; /* L60: */ - } - if (*n > 1) { + } + if (*n > 1) { /* Form P**T(2:n,2:n) */ - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } } work[1] = (doublereal) lwkopt; return 0; @@ -400,5 +400,5 @@ f"> */ } /* dorgbr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorgl2.cpp b/lib/linalg/dorgl2.cpp index a2cce985f3..68b6445522 100644 --- a/lib/linalg/dorgl2.cpp +++ b/lib/linalg/dorgl2.cpp @@ -1,13 +1,13 @@ /* fortran/dorgl2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -130,7 +130,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -138,10 +138,10 @@ f"> */ /* Local variables */ integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dlarf_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + ftnlen), xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -177,70 +177,70 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *m) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGL2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGL2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m <= 0) { - return 0; + return 0; } if (*k < *m) { /* Initialise rows k+1:m to rows of the unit matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; /* L10: */ - } - if (j > *k && j <= *m) { - a[j + j * a_dim1] = 1.; - } + } + if (j > *k && j <= *m) { + a[j + j * a_dim1] = 1.; + } /* L20: */ - } + } } for (i__ = *k; i__ >= 1; --i__) { /* Apply H(i) to A(i:m,i:n) from the right */ - if (i__ < *n) { - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & - tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], ( - ftnlen)5); - } - i__1 = *n - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; + if (i__ < *n) { + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & + tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], ( + ftnlen)5); + } + i__1 = *n - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; /* Set A(i,1:i-1) to zero */ - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[i__ + l * a_dim1] = 0.; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[i__ + l * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -250,5 +250,5 @@ f"> */ } /* dorgl2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorglq.cpp b/lib/linalg/dorglq.cpp index 3dc2d1986c..96eb224501 100644 --- a/lib/linalg/dorglq.cpp +++ b/lib/linalg/dorglq.cpp @@ -1,13 +1,13 @@ /* fortran/dorglq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -151,24 +151,24 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, + integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), - dlarfb_(char *, char *, char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -212,29 +212,29 @@ f"> */ work[1] = (doublereal) lwkopt; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *m) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } else if (*lwork < max(1,*m) && ! lquery) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGLQ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGLQ", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m <= 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; @@ -245,27 +245,27 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < *k && nx < *k) { @@ -273,85 +273,85 @@ f"> */ /* Use blocked code after the last block. */ /* The first kk rows are handled by the block method. */ - ki = (*k - nx - 1) / nb * nb; + ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); + i__1 = *k, i__2 = ki + nb; + kk = min(i__1,i__2); /* Set A(kk+1:m,1:kk) to zero. */ - i__1 = kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; + i__1 = kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } + } } else { - kk = 0; + kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *m) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); } if (kk > 0) { /* Use blocked code */ - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *m) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2,i__3); + if (i__ + ib <= *m) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__2 = *n - i__ + 1; - dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, - (ftnlen)7); + i__2 = *n - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, + (ftnlen)7); /* Apply H**T to A(i+ib:m,i:n) from the right */ - i__2 = *m - i__ - ib + 1; - i__3 = *n - i__ + 1; - dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, & - i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen) - 7); - } + i__2 = *m - i__ - ib + 1; + i__3 = *n - i__ + 1; + dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, & + i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + + 1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen) + 7); + } /* Apply H**T to columns i:n of current block */ - i__2 = *n - i__ + 1; - dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); + i__2 = *n - i__ + 1; + dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); /* Set columns 1:i-1 of current block to zero */ - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = i__ + ib - 1; - for (l = i__; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + ib - 1; + for (l = i__; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ - } + } /* L50: */ - } + } } work[1] = (doublereal) iws; @@ -362,5 +362,5 @@ f"> */ } /* dorglq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorgql.cpp b/lib/linalg/dorgql.cpp index 22a9b05b4b..719b7aa685 100644 --- a/lib/linalg/dorgql.cpp +++ b/lib/linalg/dorgql.cpp @@ -1,13 +1,13 @@ /* fortran/dorgql.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -152,24 +152,24 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, + integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), - dlarfb_(char *, char *, char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -210,42 +210,42 @@ f"> */ *info = 0; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info == 0) { - if (*n == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, ( - ftnlen)1); - lwkopt = *n * nb; - } - work[1] = (doublereal) lwkopt; + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, ( + ftnlen)1); + lwkopt = *n * nb; + } + work[1] = (doublereal) lwkopt; - if (*lwork < max(1,*n) && ! lquery) { - *info = -8; - } + if (*lwork < max(1,*n) && ! lquery) { + *info = -8; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGQL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGQL", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } nbmin = 2; @@ -256,27 +256,27 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < *k && nx < *k) { @@ -285,22 +285,22 @@ f"> */ /* The last kk columns are handled by the block method. */ /* Computing MIN */ - i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; - kk = min(i__1,i__2); + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = min(i__1,i__2); /* Set A(m-kk+1:m,1:n-kk) to zero. */ - i__1 = *n - kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } + } } else { - kk = 0; + kk = 0; } /* Use unblocked code for the first or only block. */ @@ -309,59 +309,59 @@ f"> */ i__2 = *n - kk; i__3 = *k - kk; dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) - ; + ; if (kk > 0) { /* Use blocked code */ - i__1 = *k; - i__2 = nb; - for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { /* Computing MIN */ - i__3 = nb, i__4 = *k - i__ + 1; - ib = min(i__3,i__4); - if (*n - *k + i__ > 1) { + i__3 = nb, i__4 = *k - i__ + 1; + ib = min(i__3,i__4); + if (*n - *k + i__ > 1) { /* Form the triangular factor of the block reflector */ /* H = H(i+ib-1) . . . H(i+1) H(i) */ - i__3 = *m - *k + i__ + ib - 1; - dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + - i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork, - (ftnlen)8, (ftnlen)10); + i__3 = *m - *k + i__ + ib - 1; + dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork, + (ftnlen)8, (ftnlen)10); /* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ - i__3 = *m - *k + i__ + ib - 1; - i__4 = *n - *k + i__ - 1; - dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", & - i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], - lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + - 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, ( - ftnlen)10); - } + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", & + i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], + lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, ( + ftnlen)10); + } /* Apply H to rows 1:m-k+i+ib-1 of current block */ - i__3 = *m - *k + i__ + ib - 1; - dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & - tau[i__], &work[1], &iinfo); + i__3 = *m - *k + i__ + ib - 1; + dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & + tau[i__], &work[1], &iinfo); /* Set rows m-k+i+ib:m of current block to zero */ - i__3 = *n - *k + i__ + ib - 1; - for (j = *n - *k + i__; j <= i__3; ++j) { - i__4 = *m; - for (l = *m - *k + i__ + ib; l <= i__4; ++l) { - a[l + j * a_dim1] = 0.; + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + a[l + j * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ - } + } /* L50: */ - } + } } work[1] = (doublereal) iws; @@ -372,5 +372,5 @@ f"> */ } /* dorgql_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorgqr.cpp b/lib/linalg/dorgqr.cpp index 30f175f707..4fedb08864 100644 --- a/lib/linalg/dorgqr.cpp +++ b/lib/linalg/dorgqr.cpp @@ -1,13 +1,13 @@ /* fortran/dorgqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -152,24 +152,24 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info) + a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, + integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), - dlarfb_(char *, char *, char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen, ftnlen), dlarft_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -213,29 +213,29 @@ f"> */ work[1] = (doublereal) lwkopt; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } else if (*lwork < max(1,*n) && ! lquery) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGQR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n <= 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; @@ -246,27 +246,27 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < *k && nx < *k) { @@ -274,85 +274,85 @@ f"> */ /* Use blocked code after the last block. */ /* The first kk columns are handled by the block method. */ - ki = (*k - nx - 1) / nb * nb; + ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); + i__1 = *k, i__2 = ki + nb; + kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } + } } else { - kk = 0; + kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); } if (kk > 0) { /* Use blocked code */ - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *n) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2,i__3); + if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__2 = *m - i__ + 1; - dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, - (ftnlen)10); + i__2 = *m - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, + (ftnlen)10); /* Apply H to A(i:m,i+ib:n) from the left */ - i__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", & - i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & - work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) - 7, (ftnlen)10); - } + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", & + i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & + work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) + 7, (ftnlen)10); + } /* Apply H to rows i:m of current block */ - i__2 = *m - i__ + 1; - dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); + i__2 = *m - i__ + 1; + dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); /* Set rows 1:i-1 of current block to zero */ - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; /* L30: */ - } + } /* L40: */ - } + } /* L50: */ - } + } } work[1] = (doublereal) iws; @@ -363,5 +363,5 @@ f"> */ } /* dorgqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorgtr.cpp b/lib/linalg/dorgtr.cpp index 7686c56d19..0574de0d9b 100644 --- a/lib/linalg/dorgtr.cpp +++ b/lib/linalg/dorgtr.cpp @@ -1,13 +1,13 @@ /* fortran/dorgtr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -145,8 +145,8 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info, - ftnlen uplo_len) + lda, doublereal *tau, doublereal *work, integer *lwork, integer *info, + ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -157,12 +157,12 @@ f"> */ integer iinfo; logical upper; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dorgql_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *), dorgqr_(integer *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorgql_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *), dorgqr_(integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *); integer lwkopt; logical lquery; @@ -204,52 +204,52 @@ f"> */ lquery = *lwork == -1; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - if (*lwork < max(i__1,i__2) && ! lquery) { - *info = -7; - } + i__1 = 1, i__2 = *n - 1; + if (*lwork < max(i__1,i__2) && ! lquery) { + *info = -7; + } } if (*info == 0) { - if (upper) { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)1); - } else { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)1); - } + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } /* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - lwkopt = max(i__1,i__2) * nb; - work[1] = (doublereal) lwkopt; + i__1 = 1, i__2 = *n - 1; + lwkopt = max(i__1,i__2) * nb; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORGTR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORGTR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } if (upper) { @@ -260,30 +260,30 @@ f"> */ /* column to the left, and set the last row and column of Q to */ /* those of the unit matrix */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; /* L10: */ - } - a[*n + j * a_dim1] = 0.; + } + a[*n + j * a_dim1] = 0.; /* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - a[i__ + *n * a_dim1] = 0.; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + *n * a_dim1] = 0.; /* L30: */ - } - a[*n + *n * a_dim1] = 1.; + } + a[*n + *n * a_dim1] = 1.; /* Generate Q(1:n-1,1:n-1) */ - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], - lwork, &iinfo); + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], + lwork, &iinfo); } else { @@ -293,31 +293,31 @@ f"> */ /* column to the right, and set the first row and column of Q to */ /* those of the unit matrix */ - for (j = *n; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.; - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; + for (j = *n; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; /* L40: */ - } + } /* L50: */ - } - a[a_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; + } + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; /* L60: */ - } - if (*n > 1) { + } + if (*n > 1) { /* Generate Q(2:n,2:n) */ - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], - &work[1], lwork, &iinfo); - } + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], + &work[1], lwork, &iinfo); + } } work[1] = (doublereal) lwkopt; return 0; @@ -327,5 +327,5 @@ f"> */ } /* dorgtr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorm2l.cpp b/lib/linalg/dorm2l.cpp index 6669a81614..6882f50cdb 100644 --- a/lib/linalg/dorm2l.cpp +++ b/lib/linalg/dorm2l.cpp @@ -1,13 +1,13 @@ /* fortran/dorm2l.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined +/* > \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). */ /* =========== DOCUMENTATION =========== */ @@ -179,10 +179,10 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, - ftnlen trans_len) +/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, + ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; @@ -191,9 +191,9 @@ f"> */ integer i__, i1, i2, i3, mi, ni, nq; doublereal aii; logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); logical notran; @@ -242,75 +242,75 @@ f"> */ /* NQ is the order of Q */ if (left) { - nq = *m; + nq = *m; } else { - nq = *n; + nq = *n; } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORM2L", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORM2L", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - return 0; + return 0; } if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; + i1 = 1; + i2 = *k; + i3 = 1; } else { - i1 = *k; - i2 = 1; - i3 = -1; + i1 = *k; + i2 = 1; + i3 = -1; } if (left) { - ni = *n; + ni = *n; } else { - mi = *m; + mi = *m; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { + if (left) { /* H(i) is applied to C(1:m-k+i,1:n) */ - mi = *m - *k + i__; - } else { + mi = *m - *k + i__; + } else { /* H(i) is applied to C(1:m,1:n-k+i) */ - ni = *n - *k + i__; - } + ni = *n - *k + i__; + } /* Apply H(i) */ - aii = a[nq - *k + i__ + i__ * a_dim1]; - a[nq - *k + i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ - c_offset], ldc, &work[1], (ftnlen)1); - a[nq - *k + i__ + i__ * a_dim1] = aii; + aii = a[nq - *k + i__ + i__ * a_dim1]; + a[nq - *k + i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ + c_offset], ldc, &work[1], (ftnlen)1); + a[nq - *k + i__ + i__ * a_dim1] = aii; /* L10: */ } return 0; @@ -320,5 +320,5 @@ f"> */ } /* dorm2l_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorm2r.cpp b/lib/linalg/dorm2r.cpp index 13a74e8fe1..1b600a3507 100644 --- a/lib/linalg/dorm2r.cpp +++ b/lib/linalg/dorm2r.cpp @@ -1,13 +1,13 @@ /* fortran/dorm2r.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined +/* > \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). */ /* =========== DOCUMENTATION =========== */ @@ -179,10 +179,10 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, - ftnlen trans_len) +/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, + ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; @@ -191,9 +191,9 @@ f"> */ integer i__, i1, i2, i3, ic, jc, mi, ni, nq; doublereal aii; logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); logical notran; @@ -242,79 +242,79 @@ f"> */ /* NQ is the order of Q */ if (left) { - nq = *m; + nq = *m; } else { - nq = *n; + nq = *n; } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORM2R", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORM2R", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - return 0; + return 0; } if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; + i1 = 1; + i2 = *k; + i3 = 1; } else { - i1 = *k; - i2 = 1; - i3 = -1; + i1 = *k; + i2 = 1; + i3 = -1; } if (left) { - ni = *n; - jc = 1; + ni = *n; + jc = 1; } else { - mi = *m; - ic = 1; + mi = *m; + ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { + if (left) { /* H(i) is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H(i) is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H(i) */ - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); - a[i__ + i__ * a_dim1] = aii; + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ + ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); + a[i__ + i__ * a_dim1] = aii; /* L10: */ } return 0; @@ -324,5 +324,5 @@ f"> */ } /* dorm2r_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dormbr.cpp b/lib/linalg/dormbr.cpp index e00ec3ecb0..69283d95ef 100644 --- a/lib/linalg/dormbr.cpp +++ b/lib/linalg/dormbr.cpp @@ -1,13 +1,13 @@ /* fortran/dormbr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -216,10 +216,10 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, + integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *c__, integer *ldc, doublereal *work, integer *lwork, + integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; @@ -235,15 +235,15 @@ f"> */ extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); logical notran; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen); logical applyq; char transt[1]; integer lwkopt; @@ -293,164 +293,164 @@ f"> */ /* NQ is the order of Q or P and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! applyq && ! lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -3; + *info = -3; } else if (*m < 0) { - *info = -4; + *info = -4; } else if (*n < 0) { - *info = -5; + *info = -5; } else if (*k < 0) { - *info = -6; + *info = -6; } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = 1, i__2 = min(nq,*k); - if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { - *info = -8; - } else if (*ldc < max(1,*m)) { - *info = -11; - } else if (*lwork < nw && ! lquery) { - *info = -13; - } + i__1 = 1, i__2 = min(nq,*k); + if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { + *info = -8; + } else if (*ldc < max(1,*m)) { + *info = -11; + } else if (*lwork < nw && ! lquery) { + *info = -13; + } } if (*info == 0) { - if (applyq) { - if (left) { + if (applyq) { + if (left) { /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } else { - if (left) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } else { + if (left) { /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } - lwkopt = nw * nb; - work[1] = (doublereal) lwkopt; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORMBR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORMBR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ work[1] = 1.; if (*m == 0 || *n == 0) { - return 0; + return 0; } if (applyq) { /* Apply Q */ - if (nq >= *k) { + if (nq >= *k) { /* Q was determined by a call to DGEBRD with nq >= k */ - dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( - ftnlen)1); - } else if (nq > 1) { + dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( + ftnlen)1); + } else if (nq > 1) { /* Q was determined by a call to DGEBRD with nq < k */ - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] - , &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, ( - ftnlen)1, (ftnlen)1); - } + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] + , &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, ( + ftnlen)1, (ftnlen)1); + } } else { /* Apply P */ - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - if (nq > *k) { + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + if (nq > *k) { /* P was determined by a call to DGEBRD with nq > k */ - dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( - ftnlen)1); - } else if (nq > 1) { + dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)1, ( + ftnlen)1); + } else if (nq > 1) { /* P was determined by a call to DGEBRD with nq <= k */ - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, - &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & - iinfo, (ftnlen)1, (ftnlen)1); - } + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, + &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & + iinfo, (ftnlen)1, (ftnlen)1); + } } work[1] = (doublereal) lwkopt; return 0; @@ -460,5 +460,5 @@ f"> */ } /* dormbr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dorml2.cpp b/lib/linalg/dorml2.cpp index 9085a5a0ce..7fe1aac941 100644 --- a/lib/linalg/dorml2.cpp +++ b/lib/linalg/dorml2.cpp @@ -1,13 +1,13 @@ /* fortran/dorml2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -15,7 +15,7 @@ extern "C" { #endif #include "lmp_f2c.h" -/* > \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined +/* > \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). */ /* =========== DOCUMENTATION =========== */ @@ -175,10 +175,10 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, - ftnlen trans_len) +/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *info, ftnlen side_len, + ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; @@ -187,9 +187,9 @@ f"> */ integer i__, i1, i2, i3, ic, jc, mi, ni, nq; doublereal aii; logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, ftnlen); + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); logical notran; @@ -238,79 +238,79 @@ f"> */ /* NQ is the order of Q */ if (left) { - nq = *m; + nq = *m; } else { - nq = *n; + nq = *n; } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,*k)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORML2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORML2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - return 0; + return 0; } if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; + i1 = 1; + i2 = *k; + i3 = 1; } else { - i1 = *k; - i2 = 1; - i3 = -1; + i1 = *k; + i2 = 1; + i3 = -1; } if (left) { - ni = *n; - jc = 1; + ni = *n; + jc = 1; } else { - mi = *m; - ic = 1; + mi = *m; + ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { + if (left) { /* H(i) is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H(i) is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H(i) */ - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); - a[i__ + i__ * a_dim1] = aii; + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ + ic + jc * c_dim1], ldc, &work[1], (ftnlen)1); + a[i__ + i__ * a_dim1] = aii; /* L10: */ } return 0; @@ -320,5 +320,5 @@ f"> */ } /* dorml2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dormlq.cpp b/lib/linalg/dormlq.cpp index e5ed90a9fa..bb14bbfc98 100644 --- a/lib/linalg/dormlq.cpp +++ b/lib/linalg/dormlq.cpp @@ -1,13 +1,13 @@ /* fortran/dormlq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,15 +189,15 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info, - ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *lwork, integer *info, + ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; char ch__1[2]; /* Builtin functions */ @@ -208,17 +208,17 @@ f"> */ logical left; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; - extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char - *, char *, char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char + *, char *, char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); logical notran; integer ldwork; char transt[1]; @@ -270,28 +270,28 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,*k)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { @@ -300,117 +300,117 @@ f"> */ /* Computing MIN */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = nw * nb + 4160; - work[1] = (doublereal) lwkopt; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nb = min(i__1,i__2); + lwkopt = nw * nb + 4160; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { - if (*lwork < lwkopt) { - nb = (*lwork - 4160) / ldwork; + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; /* Computing MAX */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = max(i__1,i__2); + } } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ - dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); + dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - iwt = nw * nb + 1; - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } + iwt = nw * nb + 1; + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__4 = nq - i__ + 1; - dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], - lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (ftnlen)7); - if (left) { + i__4 = nq - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], + lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, (ftnlen)7); + if (left) { /* H or H**T is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H or H**T is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H or H**T */ - dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__ - + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc * - c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, ( - ftnlen)7, (ftnlen)7); + dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__ + + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc * + c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, ( + ftnlen)7, (ftnlen)7); /* L10: */ - } + } } work[1] = (doublereal) lwkopt; return 0; @@ -420,5 +420,5 @@ f"> */ } /* dormlq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dormql.cpp b/lib/linalg/dormql.cpp index 735f9e3d2b..70694ed5f9 100644 --- a/lib/linalg/dormql.cpp +++ b/lib/linalg/dormql.cpp @@ -1,13 +1,13 @@ /* fortran/dormql.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,15 +189,15 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info, - ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *lwork, integer *info, + ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; char ch__1[2]; /* Builtin functions */ @@ -208,17 +208,17 @@ f"> */ logical left; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; - extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char - *, char *, char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char + *, char *, char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); logical notran; integer ldwork, lwkopt; logical lquery; @@ -268,141 +268,141 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { /* Compute the workspace requirements */ - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { /* Computing MIN */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1, - (ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = nw * nb + 4160; - } - work[1] = (doublereal) lwkopt; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = min(i__1,i__2); + lwkopt = nw * nb + 4160; + } + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORMQL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORMQL", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { - if (*lwork < lwkopt) { - nb = (*lwork - 4160) / ldwork; + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; /* Computing MAX */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = max(i__1,i__2); + } } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ - dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); + dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - iwt = nw * nb + 1; - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } + iwt = nw * nb + 1; + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } - if (left) { - ni = *n; - } else { - mi = *m; - } + if (left) { + ni = *n; + } else { + mi = *m; + } - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i+ib-1) . . . H(i+1) H(i) */ - i__4 = nq - *k + i__ + ib - 1; - dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] - , lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen) - 10); - if (left) { + i__4 = nq - *k + i__ + ib - 1; + dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] + , lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen) + 10); + if (left) { /* H or H**T is applied to C(1:m-k+i+ib-1,1:n) */ - mi = *m - *k + i__ + ib - 1; - } else { + mi = *m - *k + i__ + ib - 1; + } else { /* H or H**T is applied to C(1:m,1:n-k+i+ib-1) */ - ni = *n - *k + i__ + ib - 1; - } + ni = *n - *k + i__ + ib - 1; + } /* Apply H or H**T */ - dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[ - i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] - , ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8, - (ftnlen)10); + dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[ + i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] + , ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8, + (ftnlen)10); /* L10: */ - } + } } work[1] = (doublereal) lwkopt; return 0; @@ -412,5 +412,5 @@ f"> */ } /* dormql_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dormqr.cpp b/lib/linalg/dormqr.cpp index 7fce43b587..17aaab62ba 100644 --- a/lib/linalg/dormqr.cpp +++ b/lib/linalg/dormqr.cpp @@ -1,13 +1,13 @@ /* fortran/dormqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,15 +189,15 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info, - ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *lwork, integer *info, + ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; char ch__1[2]; /* Builtin functions */ @@ -208,17 +208,17 @@ f"> */ logical left; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; - extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char - *, char *, char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen), dlarfb_(char + *, char *, char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); logical notran; integer ldwork, lwkopt; logical lquery; @@ -268,28 +268,28 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { @@ -298,112 +298,112 @@ f"> */ /* Computing MIN */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = nw * nb + 4160; - work[1] = (doublereal) lwkopt; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nb = min(i__1,i__2); + lwkopt = nw * nb + 4160; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DORMQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DORMQR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { - if (*lwork < lwkopt) { - nb = (*lwork - 4160) / ldwork; + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; /* Computing MAX */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = max(i__1,i__2); + } } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ - dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); + dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - iwt = nw * nb + 1; - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } + iwt = nw * nb + 1; + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__4 = nq - i__ + 1; - dlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, ( - ftnlen)10); - if (left) { + i__4 = nq - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, ( + ftnlen)10); + if (left) { /* H or H**T is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H or H**T is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H or H**T */ - dlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[ - i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + - jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen) - 1, (ftnlen)7, (ftnlen)10); + dlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[ + i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + + jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen) + 1, (ftnlen)7, (ftnlen)10); /* L10: */ - } + } } work[1] = (doublereal) lwkopt; return 0; @@ -413,5 +413,5 @@ f"> */ } /* dormqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dormtr.cpp b/lib/linalg/dormtr.cpp index d917e95b06..a55ee5efbe 100644 --- a/lib/linalg/dormtr.cpp +++ b/lib/linalg/dormtr.cpp @@ -1,13 +1,13 @@ /* fortran/dormtr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -192,10 +192,10 @@ f"> */ /* > \ingroup doubleOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info, - ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) +/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, + integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * + c__, integer *ldc, doublereal *work, integer *lwork, integer *info, + ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; @@ -212,14 +212,14 @@ f"> */ integer iinfo; logical upper; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen), - dormqr_(char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen), + dormqr_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; @@ -266,123 +266,123 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -2; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1)) { - *info = -3; + *info = -2; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -3; } else if (*m < 0) { - *info = -4; + *info = -4; } else if (*n < 0) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { - if (upper) { - if (left) { + if (upper) { + if (left) { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, &i__2, n, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } else { - if (left) { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } else { + if (left) { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__2, n, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } - lwkopt = nw * nb; - work[1] = (doublereal) lwkopt; + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__2 = -(*info); - xerbla_((char *)"DORMTR", &i__2, (ftnlen)6); - return 0; + i__2 = -(*info); + xerbla_((char *)"DORMTR", &i__2, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || nq == 1) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } if (left) { - mi = *m - 1; - ni = *n; + mi = *m - 1; + ni = *n; } else { - mi = *m; - ni = *n - 1; + mi = *m; + ni = *n - 1; } if (upper) { /* Q was determined by a call to DSYTRD with UPLO = 'U' */ - i__2 = nq - 1; - dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & - tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen) - 1, (ftnlen)1); + i__2 = nq - 1; + dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & + tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen) + 1, (ftnlen)1); } else { /* Q was determined by a call to DSYTRD with UPLO = 'L' */ - if (left) { - i1 = 2; - i2 = 1; - } else { - i1 = 1; - i2 = 2; - } - i__2 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & - c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen) - 1, (ftnlen)1); + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & + c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen) + 1, (ftnlen)1); } work[1] = (doublereal) lwkopt; return 0; @@ -392,5 +392,5 @@ f"> */ } /* dormtr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dposv.cpp b/lib/linalg/dposv.cpp index 6981ea843d..370c261bf0 100644 --- a/lib/linalg/dposv.cpp +++ b/lib/linalg/dposv.cpp @@ -1,13 +1,13 @@ /* fortran/dposv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -146,9 +146,9 @@ extern "C" { /* > \ingroup doublePOsolve */ /* ===================================================================== */ -/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal - *a, integer *lda, doublereal *b, integer *ldb, integer *info, ftnlen - uplo_len) +/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal + *a, integer *lda, doublereal *b, integer *ldb, integer *info, ftnlen + uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; @@ -156,9 +156,9 @@ extern "C" { /* Local variables */ extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_( - char *, integer *, doublereal *, integer *, integer *, ftnlen), - dpotrs_(char *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, integer *, ftnlen); + char *, integer *, doublereal *, integer *, integer *, ftnlen), + dpotrs_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, ftnlen); /* -- LAPACK driver routine -- */ @@ -193,21 +193,21 @@ extern "C" { /* Function Body */ *info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - *info = -1; + ftnlen)1, (ftnlen)1)) { + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*nrhs < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DPOSV ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DPOSV ", &i__1, (ftnlen)6); + return 0; } /* Compute the Cholesky factorization A = U**T*U or A = L*L**T. */ @@ -217,8 +217,8 @@ extern "C" { /* Solve the system A*X = B, overwriting B with X. */ - dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info, ( - ftnlen)1); + dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info, ( + ftnlen)1); } return 0; @@ -228,5 +228,5 @@ extern "C" { } /* dposv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dpotf2.cpp b/lib/linalg/dpotf2.cpp index e32a52c97c..987db22578 100644 --- a/lib/linalg/dpotf2.cpp +++ b/lib/linalg/dpotf2.cpp @@ -1,13 +1,13 @@ /* fortran/dpotf2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -133,7 +133,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info, ftnlen uplo_len) + lda, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -145,14 +145,14 @@ f"> */ /* Local variables */ integer j; doublereal ajj; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen); logical upper; extern logical disnan_(doublereal *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -192,90 +192,90 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DPOTF2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DPOTF2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (upper) { /* Compute the Cholesky factorization A = U**T *U. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Compute U(J,J) and test for non-positive-definiteness. */ - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; + i__2 = j - 1; + ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, + &a[j * a_dim1 + 1], &c__1); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; /* Compute elements J+1:N of row J. */ - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - dgemv_((char *)"Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda, (ftnlen)9); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); - } + if (j < *n) { + i__2 = j - 1; + i__3 = *n - j; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 + + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( + j + 1) * a_dim1], lda, (ftnlen)9); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); + } /* L10: */ - } + } } else { /* Compute the Cholesky factorization A = L*L**T. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Compute L(J,J) and test for non-positive-definiteness. */ - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; + i__2 = j - 1; + ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j + + a_dim1], lda); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; /* Compute elements J+1:N of column J. */ - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - dgemv_((char *)"No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1, (ftnlen)12); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } + if (j < *n) { + i__2 = *n - j; + i__3 = j - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + + a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + + j * a_dim1], &c__1, (ftnlen)12); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } /* L20: */ - } + } } goto L40; @@ -290,5 +290,5 @@ L40: } /* dpotf2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dpotrf.cpp b/lib/linalg/dpotrf.cpp index cd343efd77..6dc003ab93 100644 --- a/lib/linalg/dpotrf.cpp +++ b/lib/linalg/dpotrf.cpp @@ -1,13 +1,13 @@ /* fortran/dpotrf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -131,28 +131,28 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info, ftnlen uplo_len) + lda, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer j, jb, nb; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical upper; - extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *, ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dpotrf2_(char *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dpotrf2_(char *, integer *, doublereal *, + integer *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -189,121 +189,121 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DPOTRF", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DPOTRF", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, (char *)"DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); + ftnlen)1); if (nb <= 1 || nb >= *n) { /* Use unblocked code. */ - dpotrf2_(uplo, n, &a[a_offset], lda, info, (ftnlen)1); + dpotrf2_(uplo, n, &a[a_offset], lda, info, (ftnlen)1); } else { /* Use blocked code. */ - if (upper) { + if (upper) { /* Compute the Cholesky factorization A = U**T*U. */ - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + i__1 = *n; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Update and factorize the current diagonal block and test */ /* for non-positive-definiteness. */ /* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_((char *)"Upper", (char *)"Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda, ( - ftnlen)5, (ftnlen)9); - dpotrf2_((char *)"Upper", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) - 5); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { + i__3 = nb, i__4 = *n - j + 1; + jb = min(i__3,i__4); + i__3 = j - 1; + dsyrk_((char *)"Upper", (char *)"Transpose", &jb, &i__3, &c_b13, &a[j * + a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda, ( + ftnlen)5, (ftnlen)9); + dpotrf2_((char *)"Upper", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) + 5); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { /* Compute the current block row. */ - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_((char *)"Transpose", (char *)"No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda, (ftnlen)9, (ftnlen)12); - i__3 = *n - j - jb + 1; - dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); - } + i__3 = *n - j - jb + 1; + i__4 = j - 1; + dgemm_((char *)"Transpose", (char *)"No transpose", &jb, &i__3, &i__4, & + c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * + a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * + a_dim1], lda, (ftnlen)9, (ftnlen)12); + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", &jb, & + i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda, (ftnlen)4, (ftnlen)5, ( + ftnlen)9, (ftnlen)8); + } /* L10: */ - } + } - } else { + } else { /* Compute the Cholesky factorization A = L*L**T. */ - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + i__2 = *n; + i__1 = nb; + for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Update and factorize the current diagonal block and test */ /* for non-positive-definiteness. */ /* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_((char *)"Lower", (char *)"No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda, ( - ftnlen)5, (ftnlen)12); - dpotrf2_((char *)"Lower", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) - 5); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { + i__3 = nb, i__4 = *n - j + 1; + jb = min(i__3,i__4); + i__3 = j - 1; + dsyrk_((char *)"Lower", (char *)"No transpose", &jb, &i__3, &c_b13, &a[j + + a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda, ( + ftnlen)5, (ftnlen)12); + dpotrf2_((char *)"Lower", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) + 5); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { /* Compute the current block column. */ - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda, ( - ftnlen)12, (ftnlen)9); - i__3 = *n - j - jb + 1; - dtrsm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)9, - (ftnlen)8); - } + i__3 = *n - j - jb + 1; + i__4 = j - 1; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, & + c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], + lda, &c_b14, &a[j + jb + j * a_dim1], lda, ( + ftnlen)12, (ftnlen)9); + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", &i__3, & + jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + + j * a_dim1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)9, + (ftnlen)8); + } /* L20: */ - } - } + } + } } goto L40; @@ -318,5 +318,5 @@ L40: } /* dpotrf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dpotrf2.cpp b/lib/linalg/dpotrf2.cpp index 9b882bb9e0..61f9c83af6 100644 --- a/lib/linalg/dpotrf2.cpp +++ b/lib/linalg/dpotrf2.cpp @@ -1,13 +1,13 @@ /* static/dpotrf2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -125,7 +125,7 @@ static doublereal c_b11 = -1.; /* ===================================================================== */ /* Subroutine */ int dpotrf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info, ftnlen uplo_len) + lda, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1; @@ -137,13 +137,13 @@ static doublereal c_b11 = -1.; integer n1, n2; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical upper; - extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, ftnlen, ftnlen); extern logical disnan_(doublereal *); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -182,22 +182,22 @@ static doublereal c_b11 = -1.; *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DPOTRF2", &i__1, (ftnlen)7); - return 0; + i__1 = -(*info); + xerbla_((char *)"DPOTRF2", &i__1, (ftnlen)7); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* N=1 case */ @@ -206,73 +206,73 @@ static doublereal c_b11 = -1.; /* Test for non-positive-definiteness */ - if (a[a_dim1 + 1] <= 0. || disnan_(&a[a_dim1 + 1])) { - *info = 1; - return 0; - } + if (a[a_dim1 + 1] <= 0. || disnan_(&a[a_dim1 + 1])) { + *info = 1; + return 0; + } /* Factor */ - a[a_dim1 + 1] = sqrt(a[a_dim1 + 1]); + a[a_dim1 + 1] = sqrt(a[a_dim1 + 1]); /* Use recursive code */ } else { - n1 = *n / 2; - n2 = *n - n1; + n1 = *n / 2; + n2 = *n - n1; /* Factor A11 */ - dpotrf2_(uplo, &n1, &a[a_dim1 + 1], lda, &iinfo, (ftnlen)1); - if (iinfo != 0) { - *info = iinfo; - return 0; - } + dpotrf2_(uplo, &n1, &a[a_dim1 + 1], lda, &iinfo, (ftnlen)1); + if (iinfo != 0) { + *info = iinfo; + return 0; + } /* Compute the Cholesky factorization A = U**T*U */ - if (upper) { + if (upper) { /* Update and scale A12 */ - dtrsm_((char *)"L", (char *)"U", (char *)"T", (char *)"N", &n1, &n2, &c_b9, &a[a_dim1 + 1], lda, & - a[(n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + dtrsm_((char *)"L", (char *)"U", (char *)"T", (char *)"N", &n1, &n2, &c_b9, &a[a_dim1 + 1], lda, & + a[(n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); /* Update and factor A22 */ - dsyrk_(uplo, (char *)"T", &n2, &n1, &c_b11, &a[(n1 + 1) * a_dim1 + 1], - lda, &c_b9, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen) - 1, (ftnlen)1); - dpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, ( - ftnlen)1); - if (iinfo != 0) { - *info = iinfo + n1; - return 0; - } + dsyrk_(uplo, (char *)"T", &n2, &n1, &c_b11, &a[(n1 + 1) * a_dim1 + 1], + lda, &c_b9, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen) + 1, (ftnlen)1); + dpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, ( + ftnlen)1); + if (iinfo != 0) { + *info = iinfo + n1; + return 0; + } /* Compute the Cholesky factorization A = L*L**T */ - } else { + } else { /* Update and scale A21 */ - dtrsm_((char *)"R", (char *)"L", (char *)"T", (char *)"N", &n2, &n1, &c_b9, &a[a_dim1 + 1], lda, & - a[n1 + 1 + a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, - (ftnlen)1); + dtrsm_((char *)"R", (char *)"L", (char *)"T", (char *)"N", &n2, &n1, &c_b9, &a[a_dim1 + 1], lda, & + a[n1 + 1 + a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, + (ftnlen)1); /* Update and factor A22 */ - dsyrk_(uplo, (char *)"N", &n2, &n1, &c_b11, &a[n1 + 1 + a_dim1], lda, & - c_b9, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, ( - ftnlen)1); - dpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, ( - ftnlen)1); - if (iinfo != 0) { - *info = iinfo + n1; - return 0; - } - } + dsyrk_(uplo, (char *)"N", &n2, &n1, &c_b11, &a[n1 + 1 + a_dim1], lda, & + c_b9, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, ( + ftnlen)1); + dpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, ( + ftnlen)1); + if (iinfo != 0) { + *info = iinfo + n1; + return 0; + } + } } return 0; @@ -281,5 +281,5 @@ static doublereal c_b11 = -1.; } /* dpotrf2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dpotrs.cpp b/lib/linalg/dpotrs.cpp index 169f851130..c8cc0e0d68 100644 --- a/lib/linalg/dpotrs.cpp +++ b/lib/linalg/dpotrs.cpp @@ -1,13 +1,13 @@ /* fortran/dpotrs.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -130,18 +130,18 @@ f"> */ /* > \ingroup doublePOcomputational */ /* ===================================================================== */ -/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info, ftnlen uplo_len) +/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; /* Local variables */ extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical upper; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); @@ -183,26 +183,26 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*nrhs < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DPOTRS", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DPOTRS", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { - return 0; + return 0; } if (upper) { @@ -211,30 +211,30 @@ f"> */ /* Solve U**T *X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[ + a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)9, (ftnlen)8); /* Solve U*X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, & + a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)12, (ftnlen)8); } else { /* Solve A*X = B where A = L*L**T. */ /* Solve L*X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, & + a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)12, (ftnlen)8); /* Solve L**T *X = B, overwriting B with X. */ - dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[ + a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( + ftnlen)9, (ftnlen)8); } return 0; @@ -244,5 +244,5 @@ f"> */ } /* dpotrs_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/drot.cpp b/lib/linalg/drot.cpp index efd339cdf0..1ed9c47a89 100644 --- a/lib/linalg/drot.cpp +++ b/lib/linalg/drot.cpp @@ -1,13 +1,13 @@ /* fortran/drot.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -105,8 +105,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *c__, doublereal *s) +/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy, doublereal *c__, doublereal *s) { /* System generated locals */ integer i__1; @@ -135,39 +135,39 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[i__] + *s * dy[i__]; - dy[i__] = *c__ * dy[i__] - *s * dx[i__]; - dx[i__] = dtemp; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; + } } else { /* code for unequal increments or equal increments not equal */ /* to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[ix] + *s * dy[iy]; - dy[iy] = *c__ * dy[iy] - *s * dx[ix]; - dx[ix] = dtemp; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; + } } return 0; @@ -176,5 +176,5 @@ extern "C" { } /* drot_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/drscl.cpp b/lib/linalg/drscl.cpp index 041c7fbba3..10904c478f 100644 --- a/lib/linalg/drscl.cpp +++ b/lib/linalg/drscl.cpp @@ -1,13 +1,13 @@ /* fortran/drscl.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -100,14 +100,14 @@ extern "C" { /* > \ingroup doubleOTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, - integer *incx) +/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, + integer *incx) { doublereal mul, cden; logical done; doublereal cnum, cden1, cnum1; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlabad_(doublereal *, doublereal *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dlabad_(doublereal *, doublereal *); extern doublereal dlamch_(char *, ftnlen); doublereal bignum, smlnum; @@ -142,7 +142,7 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } /* Get machine parameters */ @@ -163,22 +163,22 @@ L10: /* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ - mul = smlnum; - done = FALSE_; - cden = cden1; + mul = smlnum; + done = FALSE_; + cden = cden1; } else if (abs(cnum1) > abs(cden)) { /* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ - mul = bignum; - done = FALSE_; - cnum = cnum1; + mul = bignum; + done = FALSE_; + cnum = cnum1; } else { /* Multiply X by CNUM / CDEN and return. */ - mul = cnum / cden; - done = TRUE_; + mul = cnum / cden; + done = TRUE_; } /* Scale the vector X by MUL */ @@ -186,7 +186,7 @@ L10: dscal_(n, &mul, &sx[1], incx); if (! done) { - goto L10; + goto L10; } return 0; @@ -196,5 +196,5 @@ L10: } /* drscl_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dscal.cpp b/lib/linalg/dscal.cpp index d1fc1d43ee..e141f7352b 100644 --- a/lib/linalg/dscal.cpp +++ b/lib/linalg/dscal.cpp @@ -1,13 +1,13 @@ /* fortran/dscal.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -92,8 +92,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, - integer *incx) +/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, + integer *incx) { /* System generated locals */ integer i__1, i__2; @@ -123,7 +123,7 @@ extern "C" { /* Function Body */ if (*n <= 0 || *incx <= 0 || *da == 1.) { - return 0; + return 0; } if (*incx == 1) { @@ -132,35 +132,35 @@ extern "C" { /* clean-up loop */ - m = *n % 5; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dx[i__] = *da * dx[i__]; - } - if (*n < 5) { - return 0; - } - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - dx[i__] = *da * dx[i__]; - dx[i__ + 1] = *da * dx[i__ + 1]; - dx[i__ + 2] = *da * dx[i__ + 2]; - dx[i__ + 3] = *da * dx[i__ + 3]; - dx[i__ + 4] = *da * dx[i__ + 4]; - } + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dx[i__] = *da * dx[i__]; + } + if (*n < 5) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dx[i__] = *da * dx[i__]; + dx[i__ + 1] = *da * dx[i__ + 1]; + dx[i__ + 2] = *da * dx[i__ + 2]; + dx[i__ + 3] = *da * dx[i__ + 3]; + dx[i__ + 4] = *da * dx[i__ + 4]; + } } else { /* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dx[i__] = *da * dx[i__]; - } + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dx[i__] = *da * dx[i__]; + } } return 0; @@ -169,5 +169,5 @@ extern "C" { } /* dscal_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dstedc.cpp b/lib/linalg/dstedc.cpp index e71b373994..f1b09e0f25 100644 --- a/lib/linalg/dstedc.cpp +++ b/lib/linalg/dstedc.cpp @@ -1,13 +1,13 @@ /* fortran/dstedc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -212,10 +212,10 @@ f"> */ /* > Modified by Francoise Tisseur, University of Tennessee */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info, - ftnlen compz_len) +/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info, + ftnlen compz_len) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; @@ -231,37 +231,37 @@ f"> */ doublereal p; integer ii, lgn; doublereal eps, tiny; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); integer lwmin; - extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *, integer *); + extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); integer start; extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer - *, doublereal *, integer *, doublereal *, integer *, ftnlen), - dlaset_(char *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dlacpy_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, ftnlen), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); integer finish; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *), dlasrt_(char *, integer *, doublereal *, integer *, - ftnlen); + integer *), dlasrt_(char *, integer *, doublereal *, integer *, + ftnlen); integer liwmin, icompz; - extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - ftnlen); + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + ftnlen); doublereal orgnrm; logical lquery; integer smlsiz, storez, strtrw; @@ -306,82 +306,82 @@ f"> */ lquery = *lwork == -1 || *liwork == -1; if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { - icompz = 0; + icompz = 0; } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { - icompz = 1; + icompz = 1; } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { - icompz = 2; + icompz = 2; } else { - icompz = -1; + icompz = -1; } if (icompz < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; + *info = -6; } if (*info == 0) { /* Compute the workspace requirements */ - smlsiz = ilaenv_(&c__9, (char *)"DSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( - ftnlen)6, (ftnlen)1); - if (*n <= 1 || icompz == 0) { - liwmin = 1; - lwmin = 1; - } else if (*n <= smlsiz) { - liwmin = 1; - lwmin = *n - 1 << 1; - } else { - lgn = (integer) (log((doublereal) (*n)) / log(2.)); - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (icompz == 1) { + smlsiz = ilaenv_(&c__9, (char *)"DSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + liwmin = 1; + lwmin = 1; + } else if (*n <= smlsiz) { + liwmin = 1; + lwmin = *n - 1 << 1; + } else { + lgn = (integer) (log((doublereal) (*n)) / log(2.)); + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (icompz == 1) { /* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); - liwmin = *n * 6 + 6 + *n * 5 * lgn; - } else if (icompz == 2) { + i__1 = *n; + lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { /* Computing 2nd power */ - i__1 = *n; - lwmin = (*n << 2) + 1 + i__1 * i__1; - liwmin = *n * 5 + 3; - } - } - work[1] = (doublereal) lwmin; - iwork[1] = liwmin; + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + } + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*liwork < liwmin && ! lquery) { - *info = -10; - } + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSTEDC", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSTEDC", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - if (icompz != 0) { - z__[z_dim1 + 1] = 1.; - } - return 0; + if (icompz != 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; } /* If the following conditional clause is removed, then the routine */ @@ -396,8 +396,8 @@ f"> */ /* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */ if (icompz == 0) { - dsterf_(n, &d__[1], &e[1], info); - goto L50; + dsterf_(n, &d__[1], &e[1], info); + goto L50; } /* If N is smaller than the minimum divide size (SMLSIZ+1), then */ @@ -405,40 +405,40 @@ f"> */ if (*n <= smlsiz) { - dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info, - (ftnlen)1); + dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info, + (ftnlen)1); } else { /* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */ /* use. */ - if (icompz == 1) { - storez = *n * *n + 1; - } else { - storez = 1; - } + if (icompz == 1) { + storez = *n * *n + 1; + } else { + storez = 1; + } - if (icompz == 2) { - dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz, ( - ftnlen)4); - } + if (icompz == 2) { + dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz, ( + ftnlen)4); + } /* Scale. */ - orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); - if (orgnrm == 0.) { - goto L50; - } + orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); + if (orgnrm == 0.) { + goto L50; + } - eps = dlamch_((char *)"Epsilon", (ftnlen)7); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); - start = 1; + start = 1; /* while ( START <= N ) */ L10: - if (start <= *n) { + if (start <= *n) { /* Let FINISH be the position of the next subdiagonal entry */ /* such that E( FINISH ) <= TINY or FINISH = N if no such */ @@ -446,119 +446,119 @@ L10: /* between START and FINISH constitutes an independent */ /* sub-problem. */ - finish = start; + finish = start; L20: - if (finish < *n) { - tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( - d__2 = d__[finish + 1], abs(d__2))); - if ((d__1 = e[finish], abs(d__1)) > tiny) { - ++finish; - goto L20; - } - } + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( + d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L20; + } + } /* (Sub) Problem determined. Compute its size and solve it. */ - m = finish - start + 1; - if (m == 1) { - start = finish + 1; - goto L10; - } - if (m > smlsiz) { + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + if (m > smlsiz) { /* Scale. */ - orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ - start], &m, info, (ftnlen)1); - i__1 = m - 1; - i__2 = m - 1; - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ - start], &i__2, info, (ftnlen)1); + orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ + start], &m, info, (ftnlen)1); + i__1 = m - 1; + i__2 = m - 1; + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ + start], &i__2, info, (ftnlen)1); - if (icompz == 1) { - strtrw = 1; - } else { - strtrw = start; - } - dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + - start * z_dim1], ldz, &work[1], n, &work[storez], & - iwork[1], info); - if (*info != 0) { - *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % - (m + 1) + start - 1; - goto L50; - } + if (icompz == 1) { + strtrw = 1; + } else { + strtrw = start; + } + dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + + start * z_dim1], ldz, &work[1], n, &work[storez], & + iwork[1], info); + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % + (m + 1) + start - 1; + goto L50; + } /* Scale back. */ - dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ - start], &m, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ + start], &m, info, (ftnlen)1); - } else { - if (icompz == 1) { + } else { + if (icompz == 1) { /* Since QR won't update a Z matrix which is larger than */ /* the length of D, we must solve the sub-problem in a */ /* workspace and then multiply back into Z. */ - dsteqr_((char *)"I", &m, &d__[start], &e[start], &work[1], &m, & - work[m * m + 1], info, (ftnlen)1); - dlacpy_((char *)"A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[ - storez], n, (ftnlen)1); - dgemm_((char *)"N", (char *)"N", n, &m, &m, &c_b18, &work[storez], n, & - work[1], &m, &c_b17, &z__[start * z_dim1 + 1], - ldz, (ftnlen)1, (ftnlen)1); - } else if (icompz == 2) { - dsteqr_((char *)"I", &m, &d__[start], &e[start], &z__[start + - start * z_dim1], ldz, &work[1], info, (ftnlen)1); - } else { - dsterf_(&m, &d__[start], &e[start], info); - } - if (*info != 0) { - *info = start * (*n + 1) + finish; - goto L50; - } - } + dsteqr_((char *)"I", &m, &d__[start], &e[start], &work[1], &m, & + work[m * m + 1], info, (ftnlen)1); + dlacpy_((char *)"A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[ + storez], n, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", n, &m, &m, &c_b18, &work[storez], n, & + work[1], &m, &c_b17, &z__[start * z_dim1 + 1], + ldz, (ftnlen)1, (ftnlen)1); + } else if (icompz == 2) { + dsteqr_((char *)"I", &m, &d__[start], &e[start], &z__[start + + start * z_dim1], ldz, &work[1], info, (ftnlen)1); + } else { + dsterf_(&m, &d__[start], &e[start], info); + } + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } - start = finish + 1; - goto L10; - } + start = finish + 1; + goto L10; + } /* endwhile */ - if (icompz == 0) { + if (icompz == 0) { /* Use Quick Sort */ - dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); - } else { + } else { /* Use Selection Sort to minimize swaps of eigenvectors */ - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } /* L30: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 - + 1], &c__1); - } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + + 1], &c__1); + } /* L40: */ - } - } + } + } } L50: @@ -572,5 +572,5 @@ L50: } /* dstedc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsteqr.cpp b/lib/linalg/dsteqr.cpp index 65209d15d3..62a13f9d0b 100644 --- a/lib/linalg/dsteqr.cpp +++ b/lib/linalg/dsteqr.cpp @@ -1,13 +1,13 @@ /* fortran/dsteqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -155,9 +155,9 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info, ftnlen compz_len) +/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *info, ftnlen compz_len) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; @@ -175,34 +175,34 @@ f"> */ integer lsv; doublereal tst, eps2; integer lend, jtot; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen, ftnlen); doublereal anorm; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *), dlaev2_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dlaev2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); integer lendm1, lendp1; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dlaset_(char *, integer *, integer - *, doublereal *, doublereal *, doublereal *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dlaset_(char *, integer *, integer + *, doublereal *, doublereal *, doublereal *, integer *, ftnlen); doublereal safmin; - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); doublereal safmax; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *, ftnlen); integer lendsv; doublereal ssfmin; integer nmaxit, icompz; @@ -246,38 +246,38 @@ f"> */ *info = 0; if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { - icompz = 0; + icompz = 0; } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { - icompz = 1; + icompz = 1; } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { - icompz = 2; + icompz = 2; } else { - icompz = -1; + icompz = -1; } if (icompz < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; + *info = -6; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSTEQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSTEQR", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - if (icompz == 2) { - z__[z_dim1 + 1] = 1.; - } - return 0; + if (icompz == 2) { + z__[z_dim1 + 1] = 1.; + } + return 0; } /* Determine the unit roundoff and over/underflow thresholds. */ @@ -295,7 +295,7 @@ f"> */ /* matrix. */ if (icompz == 2) { - dlaset_((char *)"Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4); + dlaset_((char *)"Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4); } nmaxit = *n * 30; @@ -310,25 +310,25 @@ f"> */ L10: if (l1 > *n) { - goto L160; + goto L160; } if (l1 > 1) { - e[l1 - 1] = 0.; + e[l1 - 1] = 0.; } if (l1 <= nm1) { - i__1 = nm1; - for (m = l1; m <= i__1; ++m) { - tst = (d__1 = e[m], abs(d__1)); - if (tst == 0.) { - goto L30; - } - if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m - + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } /* L20: */ - } + } } m = *n; @@ -339,7 +339,7 @@ L30: lendsv = lend; l1 = m + 1; if (lend == l) { - goto L10; + goto L10; } /* Scale submatrix in rows and columns L to LEND */ @@ -348,31 +348,31 @@ L30: anorm = dlanst_((char *)"M", &i__1, &d__[l], &e[l], (ftnlen)1); iscale = 0; if (anorm == 0.) { - goto L10; + goto L10; } if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } /* Choose between QL and QR iteration */ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; + lend = lsv; + l = lendsv; } if (lend > l) { @@ -382,120 +382,120 @@ L30: /* Look for small subdiagonal element. */ L40: - if (l != lend) { - lendm1 = lend - 1; - i__1 = lendm1; - for (m = l; m <= i__1; ++m) { + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { /* Computing 2nd power */ - d__2 = (d__1 = e[m], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - + 1], abs(d__2)) + safmin) { - goto L60; - } + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + + 1], abs(d__2)) + safmin) { + goto L60; + } /* L50: */ - } - } + } + } - m = lend; + m = lend; L60: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L80; - } + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } /* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ /* to compute its eigensystem. */ - if (m == l + 1) { - if (icompz > 0) { - dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); - work[l] = c__; - work[*n - 1 + l] = s; - dlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], & - z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - } else { - dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); - } - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L40; - } - goto L140; - } + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + dlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], & + z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } - if (jtot == nmaxit) { - goto L140; - } - ++jtot; + if (jtot == nmaxit) { + goto L140; + } + ++jtot; /* Form shift. */ - g = (d__[l + 1] - p) / (e[l] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); - s = 1.; - c__ = 1.; - p = 0.; + s = 1.; + c__ = 1.; + p = 0.; /* Inner loop */ - mm1 = m - 1; - i__1 = l; - for (i__ = mm1; i__ >= i__1; --i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m - 1) { - e[i__ + 1] = r__; - } - g = d__[i__ + 1] - p; - r__ = (d__[i__] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__ + 1] = g + p; - g = c__ * r__ - b; + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; /* If eigenvectors are desired, then save rotations. */ - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = -s; - } + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } /* L70: */ - } + } /* If eigenvectors are desired, then apply saved rotations. */ - if (icompz > 0) { - mm = m - l + 1; - dlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l - * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (icompz > 0) { + mm = m - l + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l + * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } - d__[l] -= p; - e[l] = g; - goto L40; + d__[l] -= p; + e[l] = g; + goto L40; /* Eigenvalue found. */ L80: - d__[l] = p; + d__[l] = p; - ++l; - if (l <= lend) { - goto L40; - } - goto L140; + ++l; + if (l <= lend) { + goto L40; + } + goto L140; } else { @@ -504,121 +504,121 @@ L80: /* Look for small superdiagonal element. */ L90: - if (l != lend) { - lendp1 = lend + 1; - i__1 = lendp1; - for (m = l; m >= i__1; --m) { + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { /* Computing 2nd power */ - d__2 = (d__1 = e[m - 1], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - - 1], abs(d__2)) + safmin) { - goto L110; - } + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + - 1], abs(d__2)) + safmin) { + goto L110; + } /* L100: */ - } - } + } + } - m = lend; + m = lend; L110: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L130; - } + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } /* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ /* to compute its eigensystem. */ - if (m == l - 1) { - if (icompz > 0) { - dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) - ; - work[m] = c__; - work[*n - 1 + m] = s; - dlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], & - z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, - (ftnlen)1); - } else { - dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); - } - d__[l - 1] = rt1; - d__[l] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L90; - } - goto L140; - } + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) + ; + work[m] = c__; + work[*n - 1 + m] = s; + dlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], & + z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } - if (jtot == nmaxit) { - goto L140; - } - ++jtot; + if (jtot == nmaxit) { + goto L140; + } + ++jtot; /* Form shift. */ - g = (d__[l - 1] - p) / (e[l - 1] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); - s = 1.; - c__ = 1.; - p = 0.; + s = 1.; + c__ = 1.; + p = 0.; /* Inner loop */ - lm1 = l - 1; - i__1 = lm1; - for (i__ = m; i__ <= i__1; ++i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m) { - e[i__ - 1] = r__; - } - g = d__[i__] - p; - r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__] = g + p; - g = c__ * r__ - b; + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; /* If eigenvectors are desired, then save rotations. */ - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = s; - } + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } /* L120: */ - } + } /* If eigenvectors are desired, then apply saved rotations. */ - if (icompz > 0) { - mm = l - m + 1; - dlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m - * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (icompz > 0) { + mm = l - m + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m + * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } - d__[l] -= p; - e[lm1] = g; - goto L90; + d__[l] -= p; + e[lm1] = g; + goto L90; /* Eigenvalue found. */ L130: - d__[l] = p; + d__[l] = p; - --l; - if (l >= lend) { - goto L90; - } - goto L140; + --l; + if (l >= lend) { + goto L90; + } + goto L140; } @@ -626,32 +626,32 @@ L130: L140: if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); - i__1 = lendsv - lsv; - dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, - info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, + info, (ftnlen)1); } else if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); - i__1 = lendsv - lsv; - dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, - info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, + info, (ftnlen)1); } /* Check for no convergence to an eigenvalue after a total */ /* of N*MAXIT iterations. */ if (jtot < nmaxit) { - goto L10; + goto L10; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } + if (e[i__] != 0.) { + ++(*info); + } /* L150: */ } goto L190; @@ -663,33 +663,33 @@ L160: /* Use Quick Sort */ - dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); } else { /* Use Selection Sort to minimize swaps of eigenvectors */ - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } /* L170: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } /* L180: */ - } + } } L190: @@ -700,5 +700,5 @@ L190: } /* dsteqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsterf.cpp b/lib/linalg/dsterf.cpp index 03172b87f3..981374d32a 100644 --- a/lib/linalg/dsterf.cpp +++ b/lib/linalg/dsterf.cpp @@ -1,13 +1,13 @@ /* fortran/dsterf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -108,8 +108,8 @@ f"> */ /* > \ingroup auxOTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, - integer *info) +/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, + integer *info) { /* System generated locals */ integer i__1; @@ -129,22 +129,22 @@ f"> */ integer lend; doublereal rmax; integer jtot; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); doublereal gamma, alpha, sigma, anorm; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen); doublereal oldgam, safmin; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal safmax; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *, ftnlen); integer lendsv; doublereal ssfmin; integer nmaxit; @@ -186,13 +186,13 @@ f"> */ /* Quick return if possible */ if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_((char *)"DSTERF", &i__1, (ftnlen)6); - return 0; + *info = -1; + i__1 = -(*info); + xerbla_((char *)"DSTERF", &i__1, (ftnlen)6); + return 0; } if (*n <= 1) { - return 0; + return 0; } /* Determine the unit roundoff for this environment. */ @@ -221,18 +221,18 @@ f"> */ L10: if (l1 > *n) { - goto L170; + goto L170; } if (l1 > 1) { - e[l1 - 1] = 0.; + e[l1 - 1] = 0.; } i__1 = *n - 1; for (m = l1; m <= i__1; ++m) { - if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * - sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } + if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * + sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } /* L20: */ } m = *n; @@ -244,7 +244,7 @@ L30: lendsv = lend; l1 = m + 1; if (lend == l) { - goto L10; + goto L10; } /* Scale submatrix in rows and columns L to LEND */ @@ -253,39 +253,39 @@ L30: anorm = dlanst_((char *)"M", &i__1, &d__[l], &e[l], (ftnlen)1); iscale = 0; if (anorm == 0.) { - goto L10; + goto L10; } if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } i__1 = lend - 1; for (i__ = l; i__ <= i__1; ++i__) { /* Computing 2nd power */ - d__1 = e[i__]; - e[i__] = d__1 * d__1; + d__1 = e[i__]; + e[i__] = d__1 * d__1; /* L40: */ } /* Choose between QL and QR iteration */ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; + lend = lsv; + l = lendsv; } if (lend >= l) { @@ -295,98 +295,98 @@ L30: /* Look for small subdiagonal element. */ L50: - if (l != lend) { - i__1 = lend - 1; - for (m = l; m <= i__1; ++m) { - if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - + 1], abs(d__1))) { - goto L70; - } + if (l != lend) { + i__1 = lend - 1; + for (m = l; m <= i__1; ++m) { + if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + + 1], abs(d__1))) { + goto L70; + } /* L60: */ - } - } - m = lend; + } + } + m = lend; L70: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L90; - } + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L90; + } /* If remaining matrix is 2 by 2, use DLAE2 to compute its */ /* eigenvalues. */ - if (m == l + 1) { - rte = sqrt(e[l]); - dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L50; - } - goto L150; - } + if (m == l + 1) { + rte = sqrt(e[l]); + dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L50; + } + goto L150; + } - if (jtot == nmaxit) { - goto L150; - } - ++jtot; + if (jtot == nmaxit) { + goto L150; + } + ++jtot; /* Form shift. */ - rte = sqrt(e[l]); - sigma = (d__[l + 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b33); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + rte = sqrt(e[l]); + sigma = (d__[l + 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; /* Inner loop */ - i__1 = l; - for (i__ = m - 1; i__ >= i__1; --i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m - 1) { - e[i__ + 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__ + 1] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } + i__1 = l; + for (i__ = m - 1; i__ >= i__1; --i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m - 1) { + e[i__ + 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__ + 1] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } /* L80: */ - } + } - e[l] = s * p; - d__[l] = sigma + gamma; - goto L50; + e[l] = s * p; + d__[l] = sigma + gamma; + goto L50; /* Eigenvalue found. */ L90: - d__[l] = p; + d__[l] = p; - ++l; - if (l <= lend) { - goto L50; - } - goto L150; + ++l; + if (l <= lend) { + goto L50; + } + goto L150; } else { @@ -395,96 +395,96 @@ L90: /* Look for small superdiagonal element. */ L100: - i__1 = lend + 1; - for (m = l; m >= i__1; --m) { - if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - - 1], abs(d__1))) { - goto L120; - } + i__1 = lend + 1; + for (m = l; m >= i__1; --m) { + if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + - 1], abs(d__1))) { + goto L120; + } /* L110: */ - } - m = lend; + } + m = lend; L120: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L140; - } + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L140; + } /* If remaining matrix is 2 by 2, use DLAE2 to compute its */ /* eigenvalues. */ - if (m == l - 1) { - rte = sqrt(e[l - 1]); - dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); - d__[l] = rt1; - d__[l - 1] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L100; - } - goto L150; - } + if (m == l - 1) { + rte = sqrt(e[l - 1]); + dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); + d__[l] = rt1; + d__[l - 1] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L100; + } + goto L150; + } - if (jtot == nmaxit) { - goto L150; - } - ++jtot; + if (jtot == nmaxit) { + goto L150; + } + ++jtot; /* Form shift. */ - rte = sqrt(e[l - 1]); - sigma = (d__[l - 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b33); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + rte = sqrt(e[l - 1]); + sigma = (d__[l - 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; /* Inner loop */ - i__1 = l - 1; - for (i__ = m; i__ <= i__1; ++i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m) { - e[i__ - 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__ + 1]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } + i__1 = l - 1; + for (i__ = m; i__ <= i__1; ++i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m) { + e[i__ - 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__ + 1]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } /* L130: */ - } + } - e[l - 1] = s * p; - d__[l] = sigma + gamma; - goto L100; + e[l - 1] = s * p; + d__[l] = sigma + gamma; + goto L100; /* Eigenvalue found. */ L140: - d__[l] = p; + d__[l] = p; - --l; - if (l >= lend) { - goto L100; - } - goto L150; + --l; + if (l >= lend) { + goto L100; + } + goto L150; } @@ -492,27 +492,27 @@ L140: L150: if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); } if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); } /* Check for no convergence to an eigenvalue after a total */ /* of N*MAXIT iterations. */ if (jtot < nmaxit) { - goto L10; + goto L10; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } + if (e[i__] != 0.) { + ++(*info); + } /* L160: */ } goto L180; @@ -530,5 +530,5 @@ L180: } /* dsterf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dswap.cpp b/lib/linalg/dswap.cpp index a1eca4fc06..4cb6a77f67 100644 --- a/lib/linalg/dswap.cpp +++ b/lib/linalg/dswap.cpp @@ -1,13 +1,13 @@ /* fortran/dswap.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -95,8 +95,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) +/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy) { /* System generated locals */ integer i__1; @@ -127,7 +127,7 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { @@ -136,52 +136,52 @@ extern "C" { /* clean-up loop */ - m = *n % 3; - if (m != 0) { - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; - } - if (*n < 3) { - return 0; - } - } - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 3) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; - dtemp = dx[i__ + 1]; - dx[i__ + 1] = dy[i__ + 1]; - dy[i__ + 1] = dtemp; - dtemp = dx[i__ + 2]; - dx[i__ + 2] = dy[i__ + 2]; - dy[i__ + 2] = dtemp; - } + m = *n % 3; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + } + if (*n < 3) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 3) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + dtemp = dx[i__ + 1]; + dx[i__ + 1] = dy[i__ + 1]; + dy[i__ + 1] = dtemp; + dtemp = dx[i__ + 2]; + dx[i__ + 2] = dy[i__ + 2]; + dy[i__ + 2] = dtemp; + } } else { /* code for unequal increments or equal increments not equal */ /* to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[ix]; - dx[ix] = dy[iy]; - dy[iy] = dtemp; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[ix]; + dx[ix] = dy[iy]; + dy[iy] = dtemp; + ix += *incx; + iy += *incy; + } } return 0; @@ -190,5 +190,5 @@ extern "C" { } /* dswap_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsyev.cpp b/lib/linalg/dsyev.cpp index 603b633195..a222fc4b09 100644 --- a/lib/linalg/dsyev.cpp +++ b/lib/linalg/dsyev.cpp @@ -1,13 +1,13 @@ /* fortran/dsyev.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -157,8 +157,8 @@ ices */ /* ===================================================================== */ /* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a, - integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *info, ftnlen jobz_len, ftnlen uplo_len) + integer *lda, doublereal *w, doublereal *work, integer *lwork, + integer *info, ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -174,35 +174,35 @@ ices */ doublereal anrm; integer imax; doublereal rmin, rmax; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal sigma; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo; logical lower, wantz; extern doublereal dlamch_(char *, ftnlen); integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen); doublereal safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal bignum; integer indtau; extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *); - extern doublereal dlansy_(char *, char *, integer *, doublereal *, - integer *, doublereal *, ftnlen, ftnlen); + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *, ftnlen, ftnlen); integer indwrk; - extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *, - ftnlen), dsteqr_(char *, integer *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, integer *, ftnlen), - dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - ftnlen); + extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *, + ftnlen), dsteqr_(char *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen), + dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + ftnlen); integer llwork; doublereal smlnum; integer lwkopt; @@ -248,51 +248,51 @@ ices */ *info = 0; if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -1; + *info = -1; } else if (! (lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info == 0) { - nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); + nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); /* Computing MAX */ - i__1 = 1, i__2 = (nb + 2) * *n; - lwkopt = max(i__1,i__2); - work[1] = (doublereal) lwkopt; + i__1 = 1, i__2 = (nb + 2) * *n; + lwkopt = max(i__1,i__2); + work[1] = (doublereal) lwkopt; /* Computing MAX */ - i__1 = 1, i__2 = *n * 3 - 1; - if (*lwork < max(i__1,i__2) && ! lquery) { - *info = -8; - } + i__1 = 1, i__2 = *n * 3 - 1; + if (*lwork < max(i__1,i__2) && ! lquery) { + *info = -8; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYEV ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYEV ", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - w[1] = a[a_dim1 + 1]; - work[1] = 2.; - if (wantz) { - a[a_dim1 + 1] = 1.; - } - return 0; + w[1] = a[a_dim1 + 1]; + work[1] = 2.; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; } /* Get machine constants. */ @@ -307,18 +307,18 @@ ices */ /* Scale matrix to allowable range, if necessary. */ anrm = dlansy_((char *)"M", uplo, n, &a[a_offset], lda, &work[1], (ftnlen)1, ( - ftnlen)1); + ftnlen)1); iscale = 0; if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; + iscale = 1; + sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; + iscale = 1; + sigma = rmax / anrm; } if (iscale == 1) { - dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, - info, (ftnlen)1); + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info, (ftnlen)1); } /* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ @@ -328,30 +328,30 @@ ices */ indwrk = indtau + *n; llwork = *lwork - indwrk + 1; dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo, (ftnlen)1); + work[indwrk], &llwork, &iinfo, (ftnlen)1); /* For eigenvalues only, call DSTERF. For eigenvectors, first call */ /* DORGTR to generate the orthogonal matrix, then call DSTEQR. */ if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); + dsterf_(n, &w[1], &work[inde], info); } else { - dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & - llwork, &iinfo, (ftnlen)1); - dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], - info, (ftnlen)1); + dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & + llwork, &iinfo, (ftnlen)1); + dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], + info, (ftnlen)1); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); } /* Set WORK(1) to optimal workspace size. */ @@ -365,5 +365,5 @@ ices */ } /* dsyev_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsyevd.cpp b/lib/linalg/dsyevd.cpp index a0e0084884..2f8d5a145b 100644 --- a/lib/linalg/dsyevd.cpp +++ b/lib/linalg/dsyevd.cpp @@ -1,13 +1,13 @@ /* fortran/dsyevd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -207,9 +207,9 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal * - a, integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *iwork, integer *liwork, integer *info, ftnlen jobz_len, - ftnlen uplo_len) + a, integer *lda, doublereal *w, doublereal *work, integer *lwork, + integer *iwork, integer *liwork, integer *info, ftnlen jobz_len, + ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -223,8 +223,8 @@ f"> */ integer inde; doublereal anrm, rmin, rmax; integer lopt; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal sigma; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo, lwmin, liopt; @@ -232,30 +232,30 @@ f"> */ integer indwk2, llwrk2; extern doublereal dlamch_(char *, ftnlen); integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dstedc_(char *, integer *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *, integer *, ftnlen), dlacpy_( - char *, integer *, integer *, doublereal *, integer *, doublereal - *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dstedc_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, ftnlen), dlacpy_( + char *, integer *, integer *, doublereal *, integer *, doublereal + *, integer *, ftnlen); doublereal safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal bignum; integer indtau; extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *); - extern doublereal dlansy_(char *, char *, integer *, doublereal *, - integer *, doublereal *, ftnlen, ftnlen); + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *, ftnlen, ftnlen); integer indwrk, liwmin; - extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, ftnlen, ftnlen, - ftnlen), dsytrd_(char *, integer *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, ftnlen); + extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, ftnlen, ftnlen, + ftnlen), dsytrd_(char *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, ftnlen); integer llwork; doublereal smlnum; logical lquery; @@ -302,67 +302,67 @@ f"> */ *info = 0; if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -1; + *info = -1; } else if (! (lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info == 0) { - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - lopt = lwmin; - liopt = liwmin; - } else { - if (wantz) { - liwmin = *n * 5 + 3; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + lopt = lwmin; + liopt = liwmin; + } else { + if (wantz) { + liwmin = *n * 5 + 3; /* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = (*n << 1) + 1; - } + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } /* Computing MAX */ - i__1 = lwmin, i__2 = (*n << 1) + *n * ilaenv_(&c__1, (char *)"DSYTRD", - uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - lopt = max(i__1,i__2); - liopt = liwmin; - } - work[1] = (doublereal) lopt; - iwork[1] = liopt; + i__1 = lwmin, i__2 = (*n << 1) + *n * ilaenv_(&c__1, (char *)"DSYTRD", + uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lopt = max(i__1,i__2); + liopt = liwmin; + } + work[1] = (doublereal) lopt; + iwork[1] = liopt; - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*liwork < liwmin && ! lquery) { - *info = -10; - } + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYEVD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYEVD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - w[1] = a[a_dim1 + 1]; - if (wantz) { - a[a_dim1 + 1] = 1.; - } - return 0; + w[1] = a[a_dim1 + 1]; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; } /* Get machine constants. */ @@ -377,18 +377,18 @@ f"> */ /* Scale matrix to allowable range, if necessary. */ anrm = dlansy_((char *)"M", uplo, n, &a[a_offset], lda, &work[1], (ftnlen)1, ( - ftnlen)1); + ftnlen)1); iscale = 0; if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; + iscale = 1; + sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; + iscale = 1; + sigma = rmax / anrm; } if (iscale == 1) { - dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, - info, (ftnlen)1); + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info, (ftnlen)1); } /* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ @@ -401,7 +401,7 @@ f"> */ llwrk2 = *lwork - indwk2 + 1; dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo, (ftnlen)1); + work[indwrk], &llwork, &iinfo, (ftnlen)1); /* For eigenvalues only, call DSTERF. For eigenvectors, first call */ /* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ @@ -409,21 +409,21 @@ f"> */ /* Householder transformations stored in A. */ if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); + dsterf_(n, &w[1], &work[inde], info); } else { - dstedc_((char *)"I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & - llwrk2, &iwork[1], liwork, info, (ftnlen)1); - dormtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[ - indwrk], n, &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - dlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); + dstedc_((char *)"I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info, (ftnlen)1); + dormtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[ + indwrk], n, &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + dlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { - d__1 = 1. / sigma; - dscal_(n, &d__1, &w[1], &c__1); + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); } work[1] = (doublereal) lopt; @@ -436,5 +436,5 @@ f"> */ } /* dsyevd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsygs2.cpp b/lib/linalg/dsygs2.cpp index 8b0089be28..785aeb4f27 100644 --- a/lib/linalg/dsygs2.cpp +++ b/lib/linalg/dsygs2.cpp @@ -1,13 +1,13 @@ /* fortran/dsygs2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -150,9 +150,9 @@ f"> */ /* > \ingroup doubleSYcomputational */ /* ===================================================================== */ -/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info, ftnlen uplo_len) +/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; @@ -161,19 +161,19 @@ f"> */ /* Local variables */ integer k; doublereal ct, akk, bkk; - extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, ftnlen), dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen), dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); logical upper; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen), dtrsv_(char *, char *, char *, integer *, doublereal *, - integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen), - xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen), dtrsv_(char *, char *, char *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -213,162 +213,162 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (*itype < 1 || *itype > 3) { - *info = -1; + *info = -1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYGS2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYGS2", &i__1, (ftnlen)6); + return 0; } if (*itype == 1) { - if (upper) { + if (upper) { /* Compute inv(U**T)*A*inv(U) */ - i__1 = *n; - for (k = 1; k <= i__1; ++k) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(k:n,k:n) */ - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; /* Computing 2nd power */ - d__1 = bkk; - akk /= d__1 * d__1; - a[k + k * a_dim1] = akk; - if (k < *n) { - i__2 = *n - k; - d__1 = 1. / bkk; - dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); - ct = akk * -.5; - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( - k + 1) * a_dim1], lda); - i__2 = *n - k; - dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, - &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) - * a_dim1], lda, (ftnlen)1); - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( - k + 1) * a_dim1], lda); - i__2 = *n - k; - dtrsv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[k + 1 + ( - k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], - lda, (ftnlen)1, (ftnlen)9, (ftnlen)8); - } + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, + &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) + * a_dim1], lda, (ftnlen)1); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dtrsv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[k + 1 + ( + k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], + lda, (ftnlen)1, (ftnlen)9, (ftnlen)8); + } /* L10: */ - } - } else { + } + } else { /* Compute inv(L)*A*inv(L**T) */ - i__1 = *n; - for (k = 1; k <= i__1; ++k) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(k:n,k:n) */ - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; /* Computing 2nd power */ - d__1 = bkk; - akk /= d__1 * d__1; - a[k + k * a_dim1] = akk; - if (k < *n) { - i__2 = *n - k; - d__1 = 1. / bkk; - dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); - ct = akk * -.5; - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + - 1 + k * a_dim1], &c__1); - i__2 = *n - k; - dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, - &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) - * a_dim1], lda, (ftnlen)1); - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + - 1 + k * a_dim1], &c__1); - i__2 = *n - k; - dtrsv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[k + 1 - + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], - &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8); - } + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, + &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) + * a_dim1], lda, (ftnlen)1); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dtrsv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[k + 1 + + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], + &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8); + } /* L20: */ - } - } + } + } } else { - if (upper) { + if (upper) { /* Compute U*A*U**T */ - i__1 = *n; - for (k = 1; k <= i__1; ++k) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(1:k,1:k) */ - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; - i__2 = k - 1; - dtrmv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[b_offset], - ldb, &a[k * a_dim1 + 1], &c__1, (ftnlen)1, (ftnlen)12, - (ftnlen)8); - ct = akk * .5; - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + - 1], &c__1); - i__2 = k - 1; - dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * - b_dim1 + 1], &c__1, &a[a_offset], lda, (ftnlen)1); - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + - 1], &c__1); - i__2 = k - 1; - dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[b_offset], + ldb, &a[k * a_dim1 + 1], &c__1, (ftnlen)1, (ftnlen)12, + (ftnlen)8); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * + b_dim1 + 1], &c__1, &a[a_offset], lda, (ftnlen)1); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); /* Computing 2nd power */ - d__1 = bkk; - a[k + k * a_dim1] = akk * (d__1 * d__1); + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); /* L30: */ - } - } else { + } + } else { /* Compute L**T *A*L */ - i__1 = *n; - for (k = 1; k <= i__1; ++k) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(1:k,1:k) */ - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; - i__2 = k - 1; - dtrmv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[b_offset], - ldb, &a[k + a_dim1], lda, (ftnlen)1, (ftnlen)9, ( - ftnlen)8); - ct = akk * .5; - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); - i__2 = k - 1; - dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + - b_dim1], ldb, &a[a_offset], lda, (ftnlen)1); - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); - i__2 = k - 1; - dscal_(&i__2, &bkk, &a[k + a_dim1], lda); + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[b_offset], + ldb, &a[k + a_dim1], lda, (ftnlen)1, (ftnlen)9, ( + ftnlen)8); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + + b_dim1], ldb, &a[a_offset], lda, (ftnlen)1); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k + a_dim1], lda); /* Computing 2nd power */ - d__1 = bkk; - a[k + k * a_dim1] = akk * (d__1 * d__1); + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); /* L40: */ - } - } + } + } } return 0; @@ -377,5 +377,5 @@ f"> */ } /* dsygs2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsygst.cpp b/lib/linalg/dsygst.cpp index 2f5189a6f1..0ad89918d3 100644 --- a/lib/linalg/dsygst.cpp +++ b/lib/linalg/dsygst.cpp @@ -1,13 +1,13 @@ /* fortran/dsygst.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -152,9 +152,9 @@ f"> */ /* > \ingroup doubleSYcomputational */ /* ===================================================================== */ -/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info, ftnlen uplo_len) +/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; @@ -162,23 +162,23 @@ f"> */ /* Local variables */ integer k, kb, nb; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dsymm_( - char *, char *, integer *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dsymm_( + char *, char *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, ftnlen, ftnlen); logical upper; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dsygs2_( - integer *, char *, integer *, doublereal *, integer *, doublereal - *, integer *, integer *, ftnlen), dsyr2k_(char *, char *, integer - *, integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen) - , xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dsygs2_( + integer *, char *, integer *, doublereal *, integer *, doublereal + *, integer *, integer *, ftnlen), dsyr2k_(char *, char *, integer + *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen) + , xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); /* -- LAPACK computational routine -- */ @@ -218,212 +218,212 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (*itype < 1 || *itype > 3) { - *info = -1; + *info = -1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } else if (*ldb < max(1,*n)) { - *info = -7; + *info = -7; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYGST", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYGST", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, (char *)"DSYGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); + ftnlen)1); if (nb <= 1 || nb >= *n) { /* Use unblocked code */ - dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, ( - ftnlen)1); + dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, ( + ftnlen)1); } else { /* Use blocked code */ - if (*itype == 1) { - if (upper) { + if (*itype == 1) { + if (upper) { /* Compute inv(U**T)*A*inv(U) */ - i__1 = *n; - i__2 = nb; - for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ - i__3 = *n - k + 1; - kb = min(i__3,nb); + i__3 = *n - k + 1; + kb = min(i__3,nb); /* Update the upper triangle of A(k:n,k:n) */ - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info, (ftnlen)1); - if (k + kb <= *n) { - i__3 = *n - k - kb + 1; - dtrsm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, & - i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + - (k + kb) * a_dim1], lda, (ftnlen)4, (ftnlen)1, - (ftnlen)9, (ftnlen)8); - i__3 = *n - k - kb + 1; - dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * - a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, - &c_b14, &a[k + (k + kb) * a_dim1], lda, ( - ftnlen)4, (ftnlen)1); - i__3 = *n - k - kb + 1; - dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b19, &a[k + - (k + kb) * a_dim1], lda, &b[k + (k + kb) * - b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * - a_dim1], lda, (ftnlen)1, (ftnlen)9); - i__3 = *n - k - kb + 1; - dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * - a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, - &c_b14, &a[k + (k + kb) * a_dim1], lda, ( - ftnlen)4, (ftnlen)1); - i__3 = *n - k - kb + 1; - dtrsm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, - &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] - , ldb, &a[k + (k + kb) * a_dim1], lda, ( - ftnlen)5, (ftnlen)1, (ftnlen)12, (ftnlen)8); - } + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info, (ftnlen)1); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, & + i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + (k + kb) * a_dim1], lda, (ftnlen)4, (ftnlen)1, + (ftnlen)9, (ftnlen)8); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda, ( + ftnlen)4, (ftnlen)1); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b19, &a[k + + (k + kb) * a_dim1], lda, &b[k + (k + kb) * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda, (ftnlen)1, (ftnlen)9); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda, ( + ftnlen)4, (ftnlen)1); + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, + &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] + , ldb, &a[k + (k + kb) * a_dim1], lda, ( + ftnlen)5, (ftnlen)1, (ftnlen)12, (ftnlen)8); + } /* L10: */ - } - } else { + } + } else { /* Compute inv(L)*A*inv(L**T) */ - i__2 = *n; - i__1 = nb; - for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ - i__3 = *n - k + 1; - kb = min(i__3,nb); + i__3 = *n - k + 1; + kb = min(i__3,nb); /* Update the lower triangle of A(k:n,k:n) */ - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info, (ftnlen)1); - if (k + kb <= *n) { - i__3 = *n - k - kb + 1; - dtrsm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, - &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + - kb + k * a_dim1], lda, (ftnlen)5, (ftnlen)1, ( - ftnlen)9, (ftnlen)8); - i__3 = *n - k - kb + 1; - dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * - a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & - c_b14, &a[k + kb + k * a_dim1], lda, (ftnlen) - 5, (ftnlen)1); - i__3 = *n - k - kb + 1; - dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b19, &a[ - k + kb + k * a_dim1], lda, &b[k + kb + k * - b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * - a_dim1], lda, (ftnlen)1, (ftnlen)12); - i__3 = *n - k - kb + 1; - dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * - a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & - c_b14, &a[k + kb + k * a_dim1], lda, (ftnlen) - 5, (ftnlen)1); - i__3 = *n - k - kb + 1; - dtrsm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", & - i__3, &kb, &c_b14, &b[k + kb + (k + kb) * - b_dim1], ldb, &a[k + kb + k * a_dim1], lda, ( - ftnlen)4, (ftnlen)1, (ftnlen)12, (ftnlen)8); - } + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info, (ftnlen)1); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, + &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + kb + k * a_dim1], lda, (ftnlen)5, (ftnlen)1, ( + ftnlen)9, (ftnlen)8); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda, (ftnlen) + 5, (ftnlen)1); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b19, &a[ + k + kb + k * a_dim1], lda, &b[k + kb + k * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda, (ftnlen)1, (ftnlen)12); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda, (ftnlen) + 5, (ftnlen)1); + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", & + i__3, &kb, &c_b14, &b[k + kb + (k + kb) * + b_dim1], ldb, &a[k + kb + k * a_dim1], lda, ( + ftnlen)4, (ftnlen)1, (ftnlen)12, (ftnlen)8); + } /* L20: */ - } - } - } else { - if (upper) { + } + } + } else { + if (upper) { /* Compute U*A*U**T */ - i__1 = *n; - i__2 = nb; - for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ - i__3 = *n - k + 1; - kb = min(i__3,nb); + i__3 = *n - k + 1; + kb = min(i__3,nb); /* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ - i__3 = k - 1; - dtrmm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", &i__3, & - kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], - lda, (ftnlen)4, (ftnlen)1, (ftnlen)12, (ftnlen)8) - ; - i__3 = k - 1; - dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * - a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ - k * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)1); - i__3 = k - 1; - dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b14, &a[k * - a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, - &a[a_offset], lda, (ftnlen)1, (ftnlen)12); - i__3 = k - 1; - dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * - a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ - k * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)1); - i__3 = k - 1; - dtrmm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, &kb, - &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + - 1], lda, (ftnlen)5, (ftnlen)1, (ftnlen)9, (ftnlen) - 8); - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info, (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", &i__3, & + kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], + lda, (ftnlen)4, (ftnlen)1, (ftnlen)12, (ftnlen)8) + ; + i__3 = k - 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)1); + i__3 = k - 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b14, &a[k * + a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, + &a[a_offset], lda, (ftnlen)1, (ftnlen)12); + i__3 = k - 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, &kb, + &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + + 1], lda, (ftnlen)5, (ftnlen)1, (ftnlen)9, (ftnlen) + 8); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info, (ftnlen)1); /* L30: */ - } - } else { + } + } else { /* Compute L**T*A*L */ - i__2 = *n; - i__1 = nb; - for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ - i__3 = *n - k + 1; - kb = min(i__3,nb); + i__3 = *n - k + 1; + kb = min(i__3,nb); /* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ - i__3 = k - 1; - dtrmm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, & - i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], - lda, (ftnlen)5, (ftnlen)1, (ftnlen)12, (ftnlen)8); - i__3 = k - 1; - dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + - a_dim1], lda, (ftnlen)4, (ftnlen)1); - i__3 = k - 1; - dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b14, &a[k + - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ - a_offset], lda, (ftnlen)1, (ftnlen)9); - i__3 = k - 1; - dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + - a_dim1], lda, (ftnlen)4, (ftnlen)1); - i__3 = k - 1; - dtrmm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, &i__3, - &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], - lda, (ftnlen)4, (ftnlen)1, (ftnlen)9, (ftnlen)8); - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info, (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, & + i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], + lda, (ftnlen)5, (ftnlen)1, (ftnlen)12, (ftnlen)8); + i__3 = k - 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda, (ftnlen)4, (ftnlen)1); + i__3 = k - 1; + dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b14, &a[k + + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ + a_offset], lda, (ftnlen)1, (ftnlen)9); + i__3 = k - 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda, (ftnlen)4, (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, &i__3, + &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], + lda, (ftnlen)4, (ftnlen)1, (ftnlen)9, (ftnlen)8); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info, (ftnlen)1); /* L40: */ - } - } - } + } + } + } } return 0; @@ -432,5 +432,5 @@ f"> */ } /* dsygst_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsygv.cpp b/lib/linalg/dsygv.cpp index e7078e8006..bc7ed2cc76 100644 --- a/lib/linalg/dsygv.cpp +++ b/lib/linalg/dsygv.cpp @@ -1,13 +1,13 @@ /* fortran/dsygv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -197,9 +197,9 @@ static doublereal c_b16 = 1.; /* ===================================================================== */ /* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *info, - ftnlen jobz_len, ftnlen uplo_len) + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *w, doublereal *work, integer *lwork, integer *info, + ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; @@ -207,27 +207,27 @@ static doublereal c_b16 = 1.; /* Local variables */ integer nb, neig; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); char trans[1]; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical upper; extern /* Subroutine */ int dsyev_(char *, char *, integer *, doublereal * - , integer *, doublereal *, doublereal *, integer *, integer *, - ftnlen, ftnlen); + , integer *, doublereal *, doublereal *, integer *, integer *, + ftnlen, ftnlen); logical wantz; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, + integer *, integer *, ftnlen); integer lwkmin; - extern /* Subroutine */ int dsygst_(integer *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, integer *, - ftnlen); + extern /* Subroutine */ int dsygst_(integer *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen); integer lwkopt; logical lquery; @@ -274,102 +274,102 @@ static doublereal c_b16 = 1.; *info = 0; if (*itype < 1 || *itype > 3) { - *info = -1; + *info = -1; } else if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (! (upper || lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1))) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*lda < max(1,*n)) { - *info = -6; + *info = -6; } else if (*ldb < max(1,*n)) { - *info = -8; + *info = -8; } if (*info == 0) { /* Computing MAX */ - i__1 = 1, i__2 = *n * 3 - 1; - lwkmin = max(i__1,i__2); - nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); + i__1 = 1, i__2 = *n * 3 - 1; + lwkmin = max(i__1,i__2); + nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); /* Computing MAX */ - i__1 = lwkmin, i__2 = (nb + 2) * *n; - lwkopt = max(i__1,i__2); - work[1] = (doublereal) lwkopt; + i__1 = lwkmin, i__2 = (nb + 2) * *n; + lwkopt = max(i__1,i__2); + work[1] = (doublereal) lwkopt; - if (*lwork < lwkmin && ! lquery) { - *info = -11; - } + if (*lwork < lwkmin && ! lquery) { + *info = -11; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYGV ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYGV ", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Form a Cholesky factorization of B. */ dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1); if (*info != 0) { - *info = *n + *info; - return 0; + *info = *n + *info; + return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, ( - ftnlen)1); + ftnlen)1); dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info, ( - ftnlen)1, (ftnlen)1); + ftnlen)1, (ftnlen)1); if (wantz) { /* Backtransform eigenvectors to the original problem. */ - neig = *n; - if (*info > 0) { - neig = *info - 1; - } - if (*itype == 1 || *itype == 2) { + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */ - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } - dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &b[ - b_offset], ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, ( - ftnlen)1, (ftnlen)8); + dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, ( + ftnlen)1, (ftnlen)8); - } else if (*itype == 3) { + } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U**T*y */ - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } - dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &b[ - b_offset], ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, ( - ftnlen)1, (ftnlen)8); - } + dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, ( + ftnlen)1, (ftnlen)8); + } } work[1] = (doublereal) lwkopt; @@ -380,5 +380,5 @@ static doublereal c_b16 = 1.; } /* dsygv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsygvd.cpp b/lib/linalg/dsygvd.cpp index 80513dfdcc..c44f6239f6 100644 --- a/lib/linalg/dsygvd.cpp +++ b/lib/linalg/dsygvd.cpp @@ -1,13 +1,13 @@ /* fortran/dsygvd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -247,9 +247,9 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *w, doublereal *work, integer *lwork, integer *iwork, + integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; @@ -258,24 +258,24 @@ f"> */ /* Local variables */ integer lopt; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); integer lwmin; char trans[1]; integer liopt; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical upper, wantz; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_( - char *, integer *, doublereal *, integer *, integer *, ftnlen); + char *, integer *, doublereal *, integer *, integer *, ftnlen); integer liwmin; - extern /* Subroutine */ int dsyevd_(char *, char *, integer *, doublereal - *, integer *, doublereal *, doublereal *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen), dsygst_(integer *, char *, - integer *, doublereal *, integer *, doublereal *, integer *, - integer *, ftnlen); + extern /* Subroutine */ int dsyevd_(char *, char *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen), dsygst_(integer *, char *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *, ftnlen); logical lquery; @@ -322,72 +322,72 @@ f"> */ *info = 0; if (*n <= 1) { - liwmin = 1; - lwmin = 1; + liwmin = 1; + lwmin = 1; } else if (wantz) { - liwmin = *n * 5 + 3; + liwmin = *n * 5 + 3; /* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); } else { - liwmin = 1; - lwmin = (*n << 1) + 1; + liwmin = 1; + lwmin = (*n << 1) + 1; } lopt = lwmin; liopt = liwmin; if (*itype < 1 || *itype > 3) { - *info = -1; + *info = -1; } else if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (! (upper || lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1))) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*lda < max(1,*n)) { - *info = -6; + *info = -6; } else if (*ldb < max(1,*n)) { - *info = -8; + *info = -8; } if (*info == 0) { - work[1] = (doublereal) lopt; - iwork[1] = liopt; + work[1] = (doublereal) lopt; + iwork[1] = liopt; - if (*lwork < lwmin && ! lquery) { - *info = -11; - } else if (*liwork < liwmin && ! lquery) { - *info = -13; - } + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYGVD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYGVD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Form a Cholesky factorization of B. */ dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1); if (*info != 0) { - *info = *n + *info; - return 0; + *info = *n + *info; + return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, ( - ftnlen)1); + ftnlen)1); dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[ - 1], liwork, info, (ftnlen)1, (ftnlen)1); + 1], liwork, info, (ftnlen)1, (ftnlen)1); /* Computing MAX */ d__1 = (doublereal) lopt; lopt = (integer) max(d__1,work[1]); @@ -399,36 +399,36 @@ f"> */ /* Backtransform eigenvectors to the original problem. */ - if (*itype == 1 || *itype == 2) { + if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */ - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } - dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &b[b_offset] - , ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, - (ftnlen)8); + dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &b[b_offset] + , ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, + (ftnlen)8); - } else if (*itype == 3) { + } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U**T*y */ - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } - dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &b[b_offset] - , ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, - (ftnlen)8); - } + dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &b[b_offset] + , ldb, &a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, + (ftnlen)8); + } } work[1] = (doublereal) lopt; @@ -441,5 +441,5 @@ f"> */ } /* dsygvd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsymm.cpp b/lib/linalg/dsymm.cpp index 223551570d..83538c9c27 100644 --- a/lib/linalg/dsymm.cpp +++ b/lib/linalg/dsymm.cpp @@ -1,13 +1,13 @@ /* fortran/dsymm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -202,14 +202,14 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen - side_len, ftnlen uplo_len) +/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen + side_len, ftnlen uplo_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; /* Local variables */ integer i__, j, k, info; @@ -257,9 +257,9 @@ extern "C" { /* Function Body */ if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *n; + nrowa = *n; } upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); @@ -267,57 +267,57 @@ extern "C" { info = 0; if (! lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) && ! lsame_(side, (char *)"R", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 2; + info = 2; } else if (*m < 0) { - info = 3; + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*lda < max(1,nrowa)) { - info = 7; + info = 7; } else if (*ldb < max(1,*m)) { - info = 9; + info = 9; } else if (*ldc < max(1,*m)) { - info = 12; + info = 12; } if (info != 0) { - xerbla_((char *)"DSYMM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DSYMM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L30: */ - } + } /* L40: */ - } - } - return 0; + } + } + return 0; } /* Start the operations. */ @@ -326,107 +326,107 @@ extern "C" { /* Form C := alpha*A*B + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = *alpha * b[i__ + j * b_dim1]; - temp2 = 0.; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; - temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; /* L50: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] - + *alpha * temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + temp1 * a[i__ + i__ * a_dim1] + *alpha * - temp2; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } /* L60: */ - } + } /* L70: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp1 = *alpha * b[i__ + j * b_dim1]; - temp2 = 0.; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; - temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; /* L80: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] - + *alpha * temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + temp1 * a[i__ + i__ * a_dim1] + *alpha * - temp2; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } /* L90: */ - } + } /* L100: */ - } - } + } + } } else { /* Form C := alpha*B*A + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * a[j + j * a_dim1]; - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * a[j + j * a_dim1]; + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; /* L110: */ - } - } else { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + - temp1 * b[i__ + j * b_dim1]; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * b[i__ + j * b_dim1]; /* L120: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a[k + j * a_dim1]; - } else { - temp1 = *alpha * a[j + k * a_dim1]; - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[k + j * a_dim1]; + } else { + temp1 = *alpha * a[j + k * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; /* L130: */ - } + } /* L140: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a[j + k * a_dim1]; - } else { - temp1 = *alpha * a[k + j * a_dim1]; - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[j + k * a_dim1]; + } else { + temp1 = *alpha * a[k + j * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; /* L150: */ - } + } /* L160: */ - } + } /* L170: */ - } + } } return 0; @@ -436,5 +436,5 @@ extern "C" { } /* dsymm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsymv.cpp b/lib/linalg/dsymv.cpp index 4dc77ad743..542c12c97c 100644 --- a/lib/linalg/dsymv.cpp +++ b/lib/linalg/dsymv.cpp @@ -1,13 +1,13 @@ /* fortran/dsymv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -165,9 +165,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, - doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal - *beta, doublereal *y, integer *incy, ftnlen uplo_len) +/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, + doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal + *beta, doublereal *y, integer *incy, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -213,39 +213,39 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*lda < max(1,*n)) { - info = 5; + info = 5; } else if (*incx == 0) { - info = 7; + info = 7; } else if (*incy == 0) { - info = 10; + info = 10; } if (info != 0) { - xerbla_((char *)"DSYMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DSYMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; + return 0; } /* Set up the start points in X and Y. */ if (*incx > 0) { - kx = 1; + kx = 1; } else { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } if (*incy > 0) { - ky = 1; + ky = 1; } else { - ky = 1 - (*n - 1) * *incy; + ky = 1 - (*n - 1) * *incy; } /* Start the operations. In this version the elements of A are */ @@ -255,126 +255,126 @@ extern "C" { /* First form y := beta*y. */ if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; /* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; /* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; /* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; /* L40: */ - } - } - } + } + } + } } if (*alpha == 0.) { - return 0; + return 0; } if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { /* Form y when A is stored in upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; /* L50: */ - } - y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + } + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; /* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; /* L70: */ - } - y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; - jx += *incx; - jy += *incy; + } + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + jx += *incx; + jy += *incy; /* L80: */ - } - } + } + } } else { /* Form y when A is stored in lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a[j + j * a_dim1]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j + j * a_dim1]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; /* L90: */ - } - y[j] += *alpha * temp2; + } + y[j] += *alpha * temp2; /* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a[j + j * a_dim1]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j + j * a_dim1]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; /* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; /* L120: */ - } - } + } + } } return 0; @@ -384,5 +384,5 @@ extern "C" { } /* dsymv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsyr2.cpp b/lib/linalg/dsyr2.cpp index f017821e1d..d4395ee996 100644 --- a/lib/linalg/dsyr2.cpp +++ b/lib/linalg/dsyr2.cpp @@ -1,13 +1,13 @@ /* fortran/dsyr2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -160,9 +160,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda, ftnlen uplo_len) +/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *y, integer *incy, + doublereal *a, integer *lda, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -208,44 +208,44 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*incx == 0) { - info = 5; + info = 5; } else if (*incy == 0) { - info = 7; + info = 7; } else if (*lda < max(1,*n)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"DSYR2 ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DSYR2 ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || *alpha == 0.) { - return 0; + return 0; } /* Set up the start points in X and Y if the increments are not both */ /* unity. */ if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; } /* Start the operations. In this version the elements of A are */ @@ -256,84 +256,84 @@ extern "C" { /* Form A when A is stored in the upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; /* L10: */ - } - } + } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; /* L30: */ - } - } - jx += *incx; - jy += *incy; + } + } + jx += *incx; + jy += *incy; /* L40: */ - } - } + } + } } else { /* Form A when A is stored in the lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; /* L50: */ - } - } + } + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; /* L70: */ - } - } - jx += *incx; - jy += *incy; + } + } + jx += *incx; + jy += *incy; /* L80: */ - } - } + } + } } return 0; @@ -343,5 +343,5 @@ extern "C" { } /* dsyr2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsyr2k.cpp b/lib/linalg/dsyr2k.cpp index 33d32b3440..29f16539b2 100644 --- a/lib/linalg/dsyr2k.cpp +++ b/lib/linalg/dsyr2k.cpp @@ -1,13 +1,13 @@ /* fortran/dsyr2k.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -205,14 +205,14 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen - uplo_len, ftnlen trans_len) +/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen + uplo_len, ftnlen trans_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; /* Local variables */ integer i__, j, l, info; @@ -260,90 +260,90 @@ extern "C" { /* Function Body */ if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - nrowa = *n; + nrowa = *n; } else { - nrowa = *k; + nrowa = *k; } upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); info = 0; if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; } else if (*n < 0) { - info = 3; + info = 3; } else if (*k < 0) { - info = 4; + info = 4; } else if (*lda < max(1,nrowa)) { - info = 7; + info = 7; } else if (*ldb < max(1,nrowa)) { - info = 9; + info = 9; } else if (*ldc < max(1,*n)) { - info = 12; + info = 12; } if (info != 0) { - xerbla_((char *)"DSYR2K", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DSYR2K", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L30: */ - } + } /* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L50: */ - } + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L70: */ - } + } /* L80: */ - } - } - } - return 0; + } + } + } + return 0; } /* Start the operations. */ @@ -352,126 +352,126 @@ extern "C" { /* Form C := alpha*A*B**T + alpha*B*A**T + C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; /* L110: */ - } - } + } + } /* L120: */ - } + } /* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; /* L160: */ - } - } + } + } /* L170: */ - } + } /* L180: */ - } - } + } + } } else { /* Form C := alpha*A**T*B + alpha*B**T*A + C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; /* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } /* L200: */ - } + } /* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; /* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } /* L230: */ - } + } /* L240: */ - } - } + } + } } return 0; @@ -481,5 +481,5 @@ extern "C" { } /* dsyr2k_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsyrk.cpp b/lib/linalg/dsyrk.cpp index 28dc601121..4fb3e554f9 100644 --- a/lib/linalg/dsyrk.cpp +++ b/lib/linalg/dsyrk.cpp @@ -1,13 +1,13 @@ /* fortran/dsyrk.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -182,9 +182,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, - doublereal *c__, integer *ldc, ftnlen uplo_len, ftnlen trans_len) +/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, + doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, + doublereal *c__, integer *ldc, ftnlen uplo_len, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; @@ -232,88 +232,88 @@ extern "C" { /* Function Body */ if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - nrowa = *n; + nrowa = *n; } else { - nrowa = *k; + nrowa = *k; } upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); info = 0; if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; } else if (*n < 0) { - info = 3; + info = 3; } else if (*k < 0) { - info = 4; + info = 4; } else if (*lda < max(1,nrowa)) { - info = 7; + info = 7; } else if (*ldc < max(1,*n)) { - info = 10; + info = 10; } if (info != 0) { - xerbla_((char *)"DSYRK ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DSYRK ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L30: */ - } + } /* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L50: */ - } + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L70: */ - } + } /* L80: */ - } - } - } - return 0; + } + } + } + return 0; } /* Start the operations. */ @@ -322,116 +322,116 @@ extern "C" { /* Form C := alpha*A*A**T + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; /* L110: */ - } - } + } + } /* L120: */ - } + } /* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; /* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; /* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; /* L160: */ - } - } + } + } /* L170: */ - } + } /* L180: */ - } - } + } + } } else { /* Form C := alpha*A**T*A + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; /* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } /* L200: */ - } + } /* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; /* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } /* L230: */ - } + } /* L240: */ - } - } + } + } } return 0; @@ -441,5 +441,5 @@ extern "C" { } /* dsyrk_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsytd2.cpp b/lib/linalg/dsytd2.cpp index 4035fd0d58..acf22710af 100644 --- a/lib/linalg/dsytd2.cpp +++ b/lib/linalg/dsytd2.cpp @@ -1,13 +1,13 @@ /* fortran/dsytd2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -197,30 +197,30 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info, - ftnlen uplo_len) + lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info, + ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); doublereal taui; - extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, ftnlen); + extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen); doublereal alpha; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); logical upper; - extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer * - , ftnlen); + extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *), xerbla_(char *, integer * + , ftnlen); /* -- LAPACK computational routine -- */ @@ -260,122 +260,122 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYTD2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYTD2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } if (upper) { /* Reduce the upper triangle of A */ - for (i__ = *n - 1; i__ >= 1; --i__) { + for (i__ = *n - 1; i__ >= 1; --i__) { /* Generate elementary reflector H(i) = I - tau * v * v**T */ /* to annihilate A(1:i-1,i+1) */ - dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 - + 1], &c__1, &taui); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; + dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + + 1], &c__1, &taui); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; - if (taui != 0.) { + if (taui != 0.) { /* Apply H(i) from both sides to A(1:i,1:i) */ - a[i__ + (i__ + 1) * a_dim1] = 1.; + a[i__ + (i__ + 1) * a_dim1] = 1.; /* Compute x := tau * A * v storing x in TAU(1:i) */ - dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * - a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1, (ftnlen)1); + dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * + a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1, (ftnlen)1); /* Compute w := x - 1/2 * tau * (x**T * v) * v */ - alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) - * a_dim1 + 1], &c__1); - daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ - 1], &c__1); + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) + * a_dim1 + 1], &c__1); + daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ + 1], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**T - w * v**T */ - dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, - &tau[1], &c__1, &a[a_offset], lda, (ftnlen)1); + dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, + &tau[1], &c__1, &a[a_offset], lda, (ftnlen)1); - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } - d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; - tau[i__] = taui; + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } + d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; + tau[i__] = taui; /* L10: */ - } - d__[1] = a[a_dim1 + 1]; + } + d__[1] = a[a_dim1 + 1]; } else { /* Reduce the lower triangle of A */ - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) = I - tau * v * v**T */ /* to annihilate A(i+2:n,i) */ - i__2 = *n - i__; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * - a_dim1], &c__1, &taui); - e[i__] = a[i__ + 1 + i__ * a_dim1]; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * + a_dim1], &c__1, &taui); + e[i__] = a[i__ + 1 + i__ * a_dim1]; - if (taui != 0.) { + if (taui != 0.) { /* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - a[i__ + 1 + i__ * a_dim1] = 1.; + a[i__ + 1 + i__ * a_dim1] = 1.; /* Compute x := tau * A * v storing y in TAU(i:n-1) */ - i__2 = *n - i__; - dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ - i__], &c__1, (ftnlen)1); + i__2 = *n - i__; + dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ + i__], &c__1, (ftnlen)1); /* Compute w := x - 1/2 * tau * (x**T * v) * v */ - i__2 = *n - i__; - alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + - 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &c__1); + i__2 = *n - i__; + alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**T - w * v**T */ - i__2 = *n - i__; - dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, - &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, (ftnlen)1); + i__2 = *n - i__; + dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, + &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, (ftnlen)1); - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } - d__[i__] = a[i__ + i__ * a_dim1]; - tau[i__] = taui; + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } + d__[i__] = a[i__ + i__ * a_dim1]; + tau[i__] = taui; /* L20: */ - } - d__[*n] = a[*n + *n * a_dim1]; + } + d__[*n] = a[*n + *n * a_dim1]; } return 0; @@ -385,5 +385,5 @@ f"> */ } /* dsytd2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dsytrd.cpp b/lib/linalg/dsytrd.cpp index 190dd8b1ac..b29df9fb10 100644 --- a/lib/linalg/dsytrd.cpp +++ b/lib/linalg/dsytrd.cpp @@ -1,13 +1,13 @@ /* fortran/dsytrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -218,8 +218,8 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal * - work, integer *lwork, integer *info, ftnlen uplo_len) + lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal * + work, integer *lwork, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -229,16 +229,16 @@ f"> */ extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; logical upper; - extern /* Subroutine */ int dsytd2_(char *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - ftnlen), dsyr2k_(char *, char *, integer *, integer *, doublereal - *, doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, ftnlen, ftnlen), dlatrd_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *, - integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dsytd2_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen), dsyr2k_(char *, char *, integer *, integer *, doublereal + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen), dlatrd_(char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, ftnlen), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -282,38 +282,38 @@ f"> */ upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); lquery = *lwork == -1; if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else if (*lwork < 1 && ! lquery) { - *info = -9; + *info = -9; } if (*info == 0) { /* Determine the block size. */ - nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); - lwkopt = *n * nb; - work[1] = (doublereal) lwkopt; + nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1] = (doublereal) lwkopt; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DSYTRD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DSYTRD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - work[1] = 1.; - return 0; + work[1] = 1.; + return 0; } nx = *n; @@ -324,35 +324,35 @@ f"> */ /* (last block is always handled by unblocked code). */ /* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *n) { + i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *n) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: determine the */ /* minimum value of NB, and reduce NB or force use of */ /* unblocked code by setting NX = N. */ /* Computing MAX */ - i__1 = *lwork / ldwork; - nb = max(i__1,1); - nbmin = ilaenv_(&c__2, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, - (ftnlen)6, (ftnlen)1); - if (nb < nbmin) { - nx = *n; - } - } - } else { - nx = *n; - } + i__1 = *lwork / ldwork; + nb = max(i__1,1); + nbmin = ilaenv_(&c__2, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } } else { - nb = 1; + nb = 1; } if (upper) { @@ -360,86 +360,86 @@ f"> */ /* Reduce the upper triangle of A. */ /* Columns 1:kk are handled by the unblocked method. */ - kk = *n - (*n - nx + nb - 1) / nb * nb; - i__1 = kk + 1; - i__2 = -nb; - for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ - i__3 = i__ + nb - 1; - dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & - work[1], &ldwork, (ftnlen)1); + i__3 = i__ + nb - 1; + dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & + work[1], &ldwork, (ftnlen)1); /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ /* update of the form: A := A - V*W**T - W*V**T */ - i__3 = i__ - 1; - dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 - + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda, ( - ftnlen)1, (ftnlen)12); + i__3 = i__ - 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda, ( + ftnlen)1, (ftnlen)12); /* Copy superdiagonal elements back into A, and diagonal */ /* elements into D */ - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j - 1 + j * a_dim1] = e[j - 1]; - d__[j] = a[j + j * a_dim1]; + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j - 1 + j * a_dim1] = e[j - 1]; + d__[j] = a[j + j * a_dim1]; /* L10: */ - } + } /* L20: */ - } + } /* Use unblocked code to reduce the last or only block */ - dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, - (ftnlen)1); + dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, + (ftnlen)1); } else { /* Reduce the lower triangle of A */ - i__2 = *n - nx; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ - i__3 = *n - i__ + 1; - dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & - tau[i__], &work[1], &ldwork, (ftnlen)1); + i__3 = *n - i__ + 1; + dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & + tau[i__], &work[1], &ldwork, (ftnlen)1); /* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ /* an update of the form: A := A - V*W**T - W*V**T */ - i__3 = *n - i__ - nb + 1; - dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + - i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ - i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)1, (ftnlen) - 12); + i__3 = *n - i__ - nb + 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ + i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)1, (ftnlen) + 12); /* Copy subdiagonal elements back into A, and diagonal */ /* elements into D */ - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + 1 + j * a_dim1] = e[j]; - d__[j] = a[j + j * a_dim1]; + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + 1 + j * a_dim1] = e[j]; + d__[j] = a[j + j * a_dim1]; /* L30: */ - } + } /* L40: */ - } + } /* Use unblocked code to reduce the last or only block */ - i__1 = *n - i__ + 1; - dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], - &tau[i__], &iinfo, (ftnlen)1); + i__1 = *n - i__ + 1; + dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], + &tau[i__], &iinfo, (ftnlen)1); } work[1] = (doublereal) lwkopt; @@ -450,5 +450,5 @@ f"> */ } /* dsytrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrmm.cpp b/lib/linalg/dtrmm.cpp index ffb6a1ad6b..1a61cf72b1 100644 --- a/lib/linalg/dtrmm.cpp +++ b/lib/linalg/dtrmm.cpp @@ -1,13 +1,13 @@ /* fortran/dtrmm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -190,10 +190,10 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, - ftnlen transa_len, ftnlen diag_len) +/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * + lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, + ftnlen transa_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; @@ -244,276 +244,276 @@ extern "C" { /* Function Body */ lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); if (lside) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *n; + nrowa = *n; } nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); info = 0; if (! lside && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - info = 1; + info = 1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 2; + info = 2; } else if (! lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 3; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 4; + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 3; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; } else if (*m < 0) { - info = 5; + info = 5; } else if (*n < 0) { - info = 6; + info = 6; } else if (*lda < max(1,nrowa)) { - info = 9; + info = 9; } else if (*ldb < max(1,*m)) { - info = 11; + info = 11; } if (info != 0) { - xerbla_((char *)"DTRMM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DTRMM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - return 0; + } + return 0; } /* Start the operations. */ if (lside) { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*A*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; /* L30: */ - } - if (nounit) { - temp *= a[k + k * a_dim1]; - } - b[k + j * b_dim1] = temp; - } + } + if (nounit) { + temp *= a[k + k * a_dim1]; + } + b[k + j * b_dim1] = temp; + } /* L40: */ - } + } /* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - b[k + j * b_dim1] = temp; - if (nounit) { - b[k + j * b_dim1] *= a[k + k * a_dim1]; - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + b[k + j * b_dim1] = temp; + if (nounit) { + b[k + j * b_dim1] *= a[k + k * a_dim1]; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; /* L60: */ - } - } + } + } /* L70: */ - } + } /* L80: */ - } - } - } else { + } + } + } else { /* Form B := alpha*A**T*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; /* L90: */ - } - b[i__ + j * b_dim1] = *alpha * temp; + } + b[i__ + j * b_dim1] = *alpha * temp; /* L100: */ - } + } /* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; /* L120: */ - } - b[i__ + j * b_dim1] = *alpha * temp; + } + b[i__ + j * b_dim1] = *alpha * temp; /* L130: */ - } + } /* L140: */ - } - } - } + } + } + } } else { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*B*A. */ - if (upper) { - for (j = *n; j >= 1; --j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + if (upper) { + for (j = *n; j >= 1; --j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; /* L150: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; /* L160: */ - } - } + } + } /* L170: */ - } + } /* L180: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; /* L190: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; /* L200: */ - } - } + } + } /* L210: */ - } + } /* L220: */ - } - } - } else { + } + } + } else { /* Form B := alpha*B*A**T. */ - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; /* L230: */ - } - } + } + } /* L240: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; /* L250: */ - } - } + } + } /* L260: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; /* L270: */ - } - } + } + } /* L280: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; /* L290: */ - } - } + } + } /* L300: */ - } - } - } + } + } + } } return 0; @@ -523,5 +523,5 @@ extern "C" { } /* dtrmm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrmv.cpp b/lib/linalg/dtrmv.cpp index 77dbf2f66f..597fcae137 100644 --- a/lib/linalg/dtrmv.cpp +++ b/lib/linalg/dtrmv.cpp @@ -1,13 +1,13 @@ /* fortran/dtrmv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -160,9 +160,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen - uplo_len, ftnlen trans_len, ftnlen diag_len) +/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen + uplo_len, ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -208,31 +208,31 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 3; + ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*lda < max(1,*n)) { - info = 6; + info = 6; } else if (*incx == 0) { - info = 8; + info = 8; } if (info != 0) { - xerbla_((char *)"DTRMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DTRMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); @@ -241,9 +241,9 @@ extern "C" { /* will be ( N - 1 )*INCX too small for descending loops. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of A are */ @@ -253,155 +253,155 @@ extern "C" { /* Form x := A*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * a[i__ + j * a_dim1]; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * a[i__ + j * a_dim1]; /* L10: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } /* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix += *incx; /* L30: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx += *incx; + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx += *incx; /* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * a[i__ + j * a_dim1]; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * a[i__ + j * a_dim1]; /* L50: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } /* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix -= *incx; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix -= *incx; /* L70: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx -= *incx; + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx -= *incx; /* L80: */ - } - } - } + } + } + } } else { /* Form x := A**T*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - temp += a[i__ + j * a_dim1] * x[i__]; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; /* L90: */ - } - x[j] = temp; + } + x[j] = temp; /* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - temp += a[i__ + j * a_dim1] * x[ix]; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; /* L110: */ - } - x[jx] = temp; - jx -= *incx; + } + x[jx] = temp; + jx -= *incx; /* L120: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; /* L130: */ - } - x[j] = temp; + } + x[j] = temp; /* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - temp += a[i__ + j * a_dim1] * x[ix]; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; /* L150: */ - } - x[jx] = temp; - jx += *incx; + } + x[jx] = temp; + jx += *incx; /* L160: */ - } - } - } + } + } + } } return 0; @@ -411,5 +411,5 @@ extern "C" { } /* dtrmv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrsm.cpp b/lib/linalg/dtrsm.cpp index 488da4ecdc..8b815c5300 100644 --- a/lib/linalg/dtrsm.cpp +++ b/lib/linalg/dtrsm.cpp @@ -1,13 +1,13 @@ /* fortran/dtrsm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -194,10 +194,10 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, - ftnlen transa_len, ftnlen diag_len) +/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * + lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, + ftnlen transa_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; @@ -248,310 +248,310 @@ extern "C" { /* Function Body */ lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); if (lside) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *n; + nrowa = *n; } nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); info = 0; if (! lside && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - info = 1; + info = 1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 2; + info = 2; } else if (! lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 3; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 4; + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 3; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; } else if (*m < 0) { - info = 5; + info = 5; } else if (*n < 0) { - info = 6; + info = 6; } else if (*lda < max(1,nrowa)) { - info = 9; + info = 9; } else if (*ldb < max(1,*m)) { - info = 11; + info = 11; } if (info != 0) { - xerbla_((char *)"DTRSM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DTRSM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; /* L10: */ - } + } /* L20: */ - } - return 0; + } + return 0; } /* Start the operations. */ if (lside) { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*inv( A )*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; /* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; + } + } + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; /* L40: */ - } - } + } + } /* L50: */ - } + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; /* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; /* L80: */ - } - } + } + } /* L90: */ - } + } /* L100: */ - } - } - } else { + } + } + } else { /* Form B := alpha*inv( A**T )*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; /* L110: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; /* L120: */ - } + } /* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; /* L140: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; /* L150: */ - } + } /* L160: */ - } - } - } + } + } + } } else { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*B*inv( A ). */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; /* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; /* L180: */ - } - } + } + } /* L190: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; /* L200: */ - } - } + } + } /* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; + } + } else { + for (j = *n; j >= 1; --j) { + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; /* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; /* L230: */ - } - } + } + } /* L240: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; /* L250: */ - } - } + } + } /* L260: */ - } - } - } else { + } + } + } else { /* Form B := alpha*B*inv( A**T ). */ - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; /* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; /* L280: */ - } - } + } + } /* L290: */ - } - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; + } + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; /* L300: */ - } - } + } + } /* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; /* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; /* L330: */ - } - } + } + } /* L340: */ - } - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; + } + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; /* L350: */ - } - } + } + } /* L360: */ - } - } - } + } + } + } } return 0; @@ -561,5 +561,5 @@ extern "C" { } /* dtrsm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrsv.cpp b/lib/linalg/dtrsv.cpp index 58b85f9206..4044c819f6 100644 --- a/lib/linalg/dtrsv.cpp +++ b/lib/linalg/dtrsv.cpp @@ -1,13 +1,13 @@ /* fortran/dtrsv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -156,9 +156,9 @@ extern "C" { /* > \ingroup double_blas_level1 */ /* ===================================================================== */ -/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen - uplo_len, ftnlen trans_len, ftnlen diag_len) +/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen + uplo_len, ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -204,31 +204,31 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 3; + ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*lda < max(1,*n)) { - info = 6; + info = 6; } else if (*incx == 0) { - info = 8; + info = 8; } if (info != 0) { - xerbla_((char *)"DTRSV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"DTRSV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); @@ -237,9 +237,9 @@ extern "C" { /* will be ( N - 1 )*INCX too small for descending loops. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of A are */ @@ -249,155 +249,155 @@ extern "C" { /* Form x := inv( A )*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a[j + j * a_dim1]; - } - temp = x[j]; - for (i__ = j - 1; i__ >= 1; --i__) { - x[i__] -= temp * a[i__ + j * a_dim1]; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; /* L10: */ - } - } + } + } /* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a[j + j * a_dim1]; - } - temp = x[jx]; - ix = jx; - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - x[ix] -= temp * a[i__ + j * a_dim1]; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; /* L30: */ - } - } - jx -= *incx; + } + } + jx -= *incx; /* L40: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a[j + j * a_dim1]; - } - temp = x[j]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * a[i__ + j * a_dim1]; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; /* L50: */ - } - } + } + } /* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a[j + j * a_dim1]; - } - temp = x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - x[ix] -= temp * a[i__ + j * a_dim1]; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; /* L70: */ - } - } - jx += *incx; + } + } + jx += *incx; /* L80: */ - } - } - } + } + } + } } else { /* Form x := inv( A**T )*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a[i__ + j * a_dim1] * x[i__]; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; /* L90: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[j] = temp; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; /* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a[i__ + j * a_dim1] * x[ix]; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix += *incx; /* L110: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[jx] = temp; - jx += *incx; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; /* L120: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a[i__ + j * a_dim1] * x[i__]; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; /* L130: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[j] = temp; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; /* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a[i__ + j * a_dim1] * x[ix]; - ix -= *incx; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix -= *incx; /* L150: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[jx] = temp; - jx -= *incx; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx -= *incx; /* L160: */ - } - } - } + } + } + } } return 0; @@ -407,5 +407,5 @@ extern "C" { } /* dtrsv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrti2.cpp b/lib/linalg/dtrti2.cpp index f159e31b0d..79cc64b359 100644 --- a/lib/linalg/dtrti2.cpp +++ b/lib/linalg/dtrti2.cpp @@ -1,13 +1,13 @@ /* fortran/dtrti2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -131,7 +131,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info, ftnlen uplo_len, ftnlen diag_len) + a, integer *lda, integer *info, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -139,13 +139,13 @@ f"> */ /* Local variables */ integer j; doublereal ajj; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); logical upper; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); logical nounit; @@ -184,67 +184,67 @@ f"> */ upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! nounit && ! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DTRTI2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DTRTI2", &i__1, (ftnlen)6); + return 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } /* Compute elements 1:j-1 of j-th column. */ - i__2 = j - 1; - dtrmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &a[a_offset], lda, & - a[j * a_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen) - 1); - i__2 = j - 1; - dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + dtrmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &a[a_offset], lda, & + a[j * a_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen) + 1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); /* L10: */ - } + } } else { /* Compute inverse of lower triangular matrix. */ - for (j = *n; j >= 1; --j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } - if (j < *n) { + for (j = *n; j >= 1; --j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + if (j < *n) { /* Compute elements j+1:n of j-th column. */ - i__1 = *n - j; - dtrmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &a[j + 1 + (j + - 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1, ( - ftnlen)5, (ftnlen)12, (ftnlen)1); - i__1 = *n - j; - dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); - } + i__1 = *n - j; + dtrmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &a[j + 1 + (j + + 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1, ( + ftnlen)5, (ftnlen)12, (ftnlen)1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } /* L20: */ - } + } } return 0; @@ -254,5 +254,5 @@ f"> */ } /* dtrti2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dtrtri.cpp b/lib/linalg/dtrtri.cpp index faecb3dd69..a80ece791c 100644 --- a/lib/linalg/dtrtri.cpp +++ b/lib/linalg/dtrtri.cpp @@ -1,13 +1,13 @@ /* fortran/dtrtri.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -134,7 +134,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info, ftnlen uplo_len, ftnlen diag_len) + a, integer *lda, integer *info, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ address a__1[2]; @@ -147,18 +147,18 @@ f"> */ /* Local variables */ integer j, jb, nb, nn; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dtrsm_( - char *, char *, char *, char *, integer *, integer *, doublereal * - , doublereal *, integer *, doublereal *, integer *, ftnlen, - ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), dtrsm_( + char *, char *, char *, char *, integer *, integer *, doublereal * + , doublereal *, integer *, doublereal *, integer *, ftnlen, + ftnlen, ftnlen, ftnlen); logical upper; - extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal - *, integer *, integer *, ftnlen, ftnlen), xerbla_(char *, integer - *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal + *, integer *, integer *, ftnlen, ftnlen), xerbla_(char *, integer + *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); logical nounit; @@ -197,37 +197,37 @@ f"> */ upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! nounit && ! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"DTRTRI", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"DTRTRI", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Check for singularity if non-unit. */ if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.) { + return 0; + } /* L10: */ - } - *info = 0; + } + *info = 0; } /* Determine the block size for this environment. */ @@ -237,77 +237,77 @@ f"> */ i__2[1] = 1, a__1[1] = diag; s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); nb = ilaenv_(&c__1, (char *)"DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)2); + ftnlen)2); if (nb <= 1 || nb >= *n) { /* Use unblocked code */ - dtrti2_(uplo, diag, n, &a[a_offset], lda, info, (ftnlen)1, (ftnlen)1); + dtrti2_(uplo, diag, n, &a[a_offset], lda, info, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - if (upper) { + if (upper) { /* Compute inverse of upper triangular matrix */ - i__1 = *n; - i__3 = nb; - for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + i__1 = *n; + i__3 = nb; + for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { /* Computing MIN */ - i__4 = nb, i__5 = *n - j + 1; - jb = min(i__4,i__5); + i__4 = nb, i__5 = *n - j + 1; + jb = min(i__4,i__5); /* Compute rows 1:j-1 of current block column */ - i__4 = j - 1; - dtrmm_((char *)"Left", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, & - c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda, ( - ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)1); - i__4 = j - 1; - dtrsm_((char *)"Right", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, & - c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], - lda, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__4 = j - 1; + dtrmm_((char *)"Left", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, & + c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda, ( + ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__4 = j - 1; + dtrsm_((char *)"Right", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, & + c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], + lda, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)1); /* Compute inverse of current diagonal block */ - dtrti2_((char *)"Upper", diag, &jb, &a[j + j * a_dim1], lda, info, ( - ftnlen)5, (ftnlen)1); + dtrti2_((char *)"Upper", diag, &jb, &a[j + j * a_dim1], lda, info, ( + ftnlen)5, (ftnlen)1); /* L20: */ - } - } else { + } + } else { /* Compute inverse of lower triangular matrix */ - nn = (*n - 1) / nb * nb + 1; - i__3 = -nb; - for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { + nn = (*n - 1) / nb * nb + 1; + i__3 = -nb; + for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { /* Computing MIN */ - i__1 = nb, i__4 = *n - j + 1; - jb = min(i__1,i__4); - if (j + jb <= *n) { + i__1 = nb, i__4 = *n - j + 1; + jb = min(i__1,i__4); + if (j + jb <= *n) { /* Compute rows j+jb:n of current block column */ - i__1 = *n - j - jb + 1; - dtrmm_((char *)"Left", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, - &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j - + jb + j * a_dim1], lda, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)1); - i__1 = *n - j - jb + 1; - dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, - &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * - a_dim1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)12, ( - ftnlen)1); - } + i__1 = *n - j - jb + 1; + dtrmm_((char *)"Left", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, + &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j + + jb + j * a_dim1], lda, (ftnlen)4, (ftnlen)5, ( + ftnlen)12, (ftnlen)1); + i__1 = *n - j - jb + 1; + dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, + &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * + a_dim1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)12, ( + ftnlen)1); + } /* Compute inverse of current diagonal block */ - dtrti2_((char *)"Lower", diag, &jb, &a[j + j * a_dim1], lda, info, ( - ftnlen)5, (ftnlen)1); + dtrti2_((char *)"Lower", diag, &jb, &a[j + j * a_dim1], lda, info, ( + ftnlen)5, (ftnlen)1); /* L30: */ - } - } + } + } } return 0; @@ -317,5 +317,5 @@ f"> */ } /* dtrtri_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/dznrm2.cpp b/lib/linalg/dznrm2.cpp index ec71aa201b..7a92e63831 100644 --- a/lib/linalg/dznrm2.cpp +++ b/lib/linalg/dznrm2.cpp @@ -1,13 +1,13 @@ /* fortran/dznrm2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -127,48 +127,48 @@ doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx) /* Function Body */ if (*n < 1 || *incx < 1) { - norm = 0.; + norm = 0.; } else { - scale = 0.; - ssq = 1.; + scale = 0.; + ssq = 1.; /* The following loop is equivalent to this call to the LAPACK */ /* auxiliary routine: */ /* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */ - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - i__3 = ix; - if (x[i__3].r != 0.) { - i__3 = ix; - temp = (d__1 = x[i__3].r, abs(d__1)); - if (scale < temp) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + if (x[i__3].r != 0.) { + i__3 = ix; + temp = (d__1 = x[i__3].r, abs(d__1)); + if (scale < temp) { /* Computing 2nd power */ - d__1 = scale / temp; - ssq = ssq * (d__1 * d__1) + 1.; - scale = temp; - } else { + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { /* Computing 2nd power */ - d__1 = temp / scale; - ssq += d__1 * d__1; - } - } - if (d_imag(&x[ix]) != 0.) { - temp = (d__1 = d_imag(&x[ix]), abs(d__1)); - if (scale < temp) { + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } + if (d_imag(&x[ix]) != 0.) { + temp = (d__1 = d_imag(&x[ix]), abs(d__1)); + if (scale < temp) { /* Computing 2nd power */ - d__1 = scale / temp; - ssq = ssq * (d__1 * d__1) + 1.; - scale = temp; - } else { + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { /* Computing 2nd power */ - d__1 = temp / scale; - ssq += d__1 * d__1; - } - } + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } /* L10: */ - } - norm = scale * sqrt(ssq); + } + norm = scale * sqrt(ssq); } ret_val = norm; @@ -179,5 +179,5 @@ doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx) } /* dznrm2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/idamax.cpp b/lib/linalg/idamax.cpp index edcf861435..e50c15bd38 100644 --- a/lib/linalg/idamax.cpp +++ b/lib/linalg/idamax.cpp @@ -1,13 +1,13 @@ /* fortran/idamax.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -116,39 +116,39 @@ integer idamax_(integer *n, doublereal *dx, integer *incx) /* Function Body */ ret_val = 0; if (*n < 1 || *incx <= 0) { - return ret_val; + return ret_val; } ret_val = 1; if (*n == 1) { - return ret_val; + return ret_val; } if (*incx == 1) { /* code for increment equal to 1 */ - dmax__ = abs(dx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[i__], abs(d__1)) > dmax__) { - ret_val = i__; - dmax__ = (d__1 = dx[i__], abs(d__1)); - } - } + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) > dmax__) { + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); + } + } } else { /* code for increment not equal to 1 */ - ix = 1; - dmax__ = abs(dx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[ix], abs(d__1)) > dmax__) { - ret_val = i__; - dmax__ = (d__1 = dx[ix], abs(d__1)); - } - ix += *incx; - } + ix = 1; + dmax__ = abs(dx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[ix], abs(d__1)) > dmax__) { + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); + } + ix += *incx; + } } return ret_val; @@ -157,5 +157,5 @@ integer idamax_(integer *n, doublereal *dx, integer *incx) } /* idamax_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ieeeck.cpp b/lib/linalg/ieeeck.cpp index 16626acf9d..783a87df9d 100644 --- a/lib/linalg/ieeeck.cpp +++ b/lib/linalg/ieeeck.cpp @@ -1,13 +1,13 @@ /* fortran/ieeeck.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -123,50 +123,50 @@ integer ieeeck_(integer *ispec, real *zero, real *one) posinf = *one / *zero; if (posinf <= *one) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } neginf = -(*one) / *zero; if (neginf >= *zero) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } negzro = *one / (neginf + *one); if (negzro != *zero) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } neginf = *one / negzro; if (neginf >= *zero) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } newzro = negzro + *zero; if (newzro != *zero) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } posinf = *one / newzro; if (posinf <= *one) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } neginf *= posinf; if (neginf >= *zero) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } posinf *= posinf; if (posinf <= *one) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } @@ -175,7 +175,7 @@ integer ieeeck_(integer *ispec, real *zero, real *one) /* Return if we were only asked to check infinity arithmetic */ if (*ispec == 0) { - return ret_val; + return ret_val; } nan1 = posinf + neginf; @@ -191,38 +191,38 @@ integer ieeeck_(integer *ispec, real *zero, real *one) nan6 = nan5 * *zero; if (nan1 == nan1) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } if (nan2 == nan2) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } if (nan3 == nan3) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } if (nan4 == nan4) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } if (nan5 == nan5) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } if (nan6 == nan6) { - ret_val = 0; - return ret_val; + ret_val = 0; + return ret_val; } return ret_val; } /* ieeeck_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/iladlc.cpp b/lib/linalg/iladlc.cpp index 21b05e970a..20355f1a94 100644 --- a/lib/linalg/iladlc.cpp +++ b/lib/linalg/iladlc.cpp @@ -1,13 +1,13 @@ /* fortran/iladlc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,23 +128,23 @@ integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda) /* Function Body */ if (*n == 0) { - ret_val = *n; + ret_val = *n; } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *n; + ret_val = *n; } else { /* Now scan each column from the end, returning with the first non-zero. */ - for (ret_val = *n; ret_val >= 1; --ret_val) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (a[i__ + ret_val * a_dim1] != 0.) { - return ret_val; - } - } - } + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (a[i__ + ret_val * a_dim1] != 0.) { + return ret_val; + } + } + } } return ret_val; } /* iladlc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/iladlr.cpp b/lib/linalg/iladlr.cpp index a301b66170..a68f2a665e 100644 --- a/lib/linalg/iladlr.cpp +++ b/lib/linalg/iladlr.cpp @@ -1,13 +1,13 @@ /* fortran/iladlr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,24 +128,24 @@ integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda) /* Function Body */ if (*m == 0) { - ret_val = *m; + ret_val = *m; } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *m; + ret_val = *m; } else { /* Scan up each column tracking the last zero row seen. */ - ret_val = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__ = *m; - while(a[max(i__,1) + j * a_dim1] == 0. && i__ >= 1) { - --i__; - } - ret_val = max(ret_val,i__); - } + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + while(a[max(i__,1) + j * a_dim1] == 0. && i__ >= 1) { + --i__; + } + ret_val = max(ret_val,i__); + } } return ret_val; } /* iladlr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ilaenv.cpp b/lib/linalg/ilaenv.cpp index 0e9a051222..6c94f00e6f 100644 --- a/lib/linalg/ilaenv.cpp +++ b/lib/linalg/ilaenv.cpp @@ -1,13 +1,13 @@ /* fortran/ilaenv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -185,9 +185,9 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, - integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen - opts_len) +integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, + integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen + opts_len) { /* System generated locals */ integer ret_val, i__1, i__2, i__3; @@ -206,8 +206,8 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, logical sname; extern integer ieeeck_(integer *, real *, real *); char subnam[16]; - extern integer iparmq_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer iparmq_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); /* -- LAPACK auxiliary routine -- */ @@ -228,23 +228,23 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* .. Executable Statements .. */ switch (*ispec) { - case 1: goto L10; - case 2: goto L10; - case 3: goto L10; - case 4: goto L80; - case 5: goto L90; - case 6: goto L100; - case 7: goto L110; - case 8: goto L120; - case 9: goto L130; - case 10: goto L140; - case 11: goto L150; - case 12: goto L160; - case 13: goto L160; - case 14: goto L160; - case 15: goto L160; - case 16: goto L160; - case 17: goto L160; + case 1: goto L10; + case 2: goto L10; + case 3: goto L10; + case 4: goto L80; + case 5: goto L90; + case 6: goto L100; + case 7: goto L110; + case 8: goto L120; + case 9: goto L130; + case 10: goto L140; + case 11: goto L150; + case 12: goto L160; + case 13: goto L160; + case 14: goto L160; + case 15: goto L160; + case 16: goto L160; + case 17: goto L160; } /* Invalid value for ISPEC */ @@ -264,66 +264,66 @@ L10: /* ASCII character set */ - if (ic >= 97 && ic <= 122) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 97 && ic <= 122) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } /* L20: */ - } - } + } + } } else if (iz == 233 || iz == 169) { /* EBCDIC character set */ - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && - ic <= 169) { - *(unsigned char *)subnam = (char) (ic + 64); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= - 162 && ic <= 169) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); - } + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && + ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= + 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } /* L30: */ - } - } + } + } } else if (iz == 218 || iz == 250) { /* Prime machines: ASCII+128 */ - if (ic >= 225 && ic <= 250) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 225 && ic <= 250) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } /* L40: */ - } - } + } + } } *(unsigned char *)c1 = *(unsigned char *)subnam; sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; if (! (cname || sname)) { - return ret_val; + return ret_val; } s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2); s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3); s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2); twostage = i_len(subnam, (ftnlen)16) >= 11 && *(unsigned char *)&subnam[ - 10] == '2'; + 10] == '2'; switch (*ispec) { - case 1: goto L50; - case 2: goto L60; - case 3: goto L70; + case 1: goto L50; + case 2: goto L60; + case 3: goto L70; } L50: @@ -340,260 +340,260 @@ L50: /* This is for *LAORHR_GETRFNP routine */ - if (sname) { - nb = 32; - } else { - nb = 32; - } + if (sname) { + nb = 32; + } else { + nb = 32; + } } else if (s_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, - (char *)"RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen) - 3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) - == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, (char *)"QR ", (ftnlen)3, (ftnlen)3) == 0) { - if (*n3 == 1) { - if (sname) { + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, + (char *)"RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen) + 3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) + == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, (char *)"QR ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 1) { + if (sname) { /* M*N */ - if (*n1 * *n2 <= 131072 || *n1 <= 8192) { - nb = *n1; - } else { - nb = 32768 / *n2; - } - } else { - if (*n1 * *n2 <= 131072 || *n1 <= 8192) { - nb = *n1; - } else { - nb = 32768 / *n2; - } - } - } else { - if (sname) { - nb = 1; - } else { - nb = 1; - } - } - } else if (s_cmp(c3, (char *)"LQ ", (ftnlen)3, (ftnlen)3) == 0) { - if (*n3 == 2) { - if (sname) { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, (char *)"LQ ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 2) { + if (sname) { /* M*N */ - if (*n1 * *n2 <= 131072 || *n1 <= 8192) { - nb = *n1; - } else { - nb = 32768 / *n2; - } - } else { - if (*n1 * *n2 <= 131072 || *n1 <= 8192) { - nb = *n1; - } else { - nb = 32768 / *n2; - } - } - } else { - if (sname) { - nb = 1; - } else { - nb = 1; - } - } - } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } } else if (s_cmp(c2, (char *)"PO", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } } else if (s_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - if (twostage) { - nb = 192; - } else { - nb = 64; - } - } else { - if (twostage) { - nb = 192; - } else { - nb = 64; - } - } - } else if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nb = 32; - } else if (sname && s_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { - nb = 64; - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (sname && s_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } } else if (cname && s_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (twostage) { - nb = 192; - } else { - nb = 64; - } - } else if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nb = 32; - } else if (s_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { - nb = 64; - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (s_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } } else if (sname && s_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } } else if (cname && s_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } } else if (s_cmp(c2, (char *)"GB", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } } else if (s_cmp(c2, (char *)"PB", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } } else if (s_cmp(c2, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, (char *)"EVC", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, (char *)"SYL", (ftnlen)3, (ftnlen)3) == 0) { + if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, (char *)"EVC", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, (char *)"SYL", (ftnlen)3, (ftnlen)3) == 0) { /* The upper bound is to prevent overly aggressive scaling. */ - if (sname) { + if (sname) { /* Computing MIN */ /* Computing MAX */ - i__2 = 48, i__3 = (min(*n1,*n2) << 4) / 100; - i__1 = max(i__2,i__3); - nb = min(i__1,240); - } else { + i__2 = 48, i__3 = (min(*n1,*n2) << 4) / 100; + i__1 = max(i__2,i__3); + nb = min(i__1,240); + } else { /* Computing MIN */ /* Computing MAX */ - i__2 = 24, i__3 = (min(*n1,*n2) << 3) / 100; - i__1 = max(i__2,i__3); - nb = min(i__1,80); - } - } + i__2 = 24, i__3 = (min(*n1,*n2) << 3) / 100; + i__1 = max(i__2,i__3); + nb = min(i__1,80); + } + } } else if (s_cmp(c2, (char *)"LA", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"UUM", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, (char *)"TRS", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } + if (s_cmp(c3, (char *)"UUM", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, (char *)"TRS", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } } else if (sname && s_cmp(c2, (char *)"ST", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"EBZ", (ftnlen)3, (ftnlen)3) == 0) { - nb = 1; - } + if (s_cmp(c3, (char *)"EBZ", (ftnlen)3, (ftnlen)3) == 0) { + nb = 1; + } } else if (s_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } + nb = 32; + if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } } ret_val = nb; return ret_val; @@ -604,93 +604,93 @@ L60: nbmin = 2; if (s_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"RQF", ( - ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen)3, ( - ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) - { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } + if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"RQF", ( + ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen)3, ( + ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) + { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } } else if (s_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 8; - } else { - nbmin = 8; - } - } else if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nbmin = 2; - } + if (s_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 8; + } else { + nbmin = 8; + } + } else if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } } else if (cname && s_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nbmin = 2; - } + if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } } else if (sname && s_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } } else if (cname && s_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } } else if (s_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { - nbmin = 2; - } + nbmin = 2; + if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } } ret_val = nbmin; return ret_val; @@ -701,63 +701,63 @@ L70: nx = 0; if (s_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"RQF", ( - ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen)3, ( - ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) - { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } + if (s_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"RQF", ( + ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, (char *)"LQF", (ftnlen)3, ( + ftnlen)3) == 0 || s_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) + { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } } else if (s_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { - if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nx = 32; - } + if (sname && s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } } else if (cname && s_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { - nx = 32; - } + if (s_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } } else if (sname && s_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nx = 128; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } } else if (cname && s_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nx = 128; - } - } + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, (char *)"BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } } else if (s_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { - nx = 128; - if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { - nx = 128; - } + nx = 128; + if (s_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + nx = 128; + } } ret_val = nx; return ret_val; @@ -813,7 +813,7 @@ L140: /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__1, &c_b176, &c_b177); + ret_val = ieeeck_(&c__1, &c_b176, &c_b177); } return ret_val; @@ -824,7 +824,7 @@ L150: /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__0, &c_b176, &c_b177); + ret_val = ieeeck_(&c__0, &c_b176, &c_b177); } return ret_val; @@ -833,7 +833,7 @@ L160: /* 12 <= ISPEC <= 17: xHSEQR or related subroutines. */ ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4, name_len, opts_len) - ; + ; return ret_val; /* End of ILAENV */ @@ -841,5 +841,5 @@ L160: } /* ilaenv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ilazlc.cpp b/lib/linalg/ilazlc.cpp index 309c9e5edb..eb3f9ed604 100644 --- a/lib/linalg/ilazlc.cpp +++ b/lib/linalg/ilazlc.cpp @@ -1,13 +1,13 @@ /* fortran/ilazlc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,29 +128,29 @@ integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda) /* Function Body */ if (*n == 0) { - ret_val = *n; + ret_val = *n; } else /* if(complicated condition) */ { - i__1 = *n * a_dim1 + 1; - i__2 = *m + *n * a_dim1; - if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] - .i != 0.)) { - ret_val = *n; - } else { + i__1 = *n * a_dim1 + 1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] + .i != 0.)) { + ret_val = *n; + } else { /* Now scan each column from the end, returning with the first non-zero. */ - for (ret_val = *n; ret_val >= 1; --ret_val) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + ret_val * a_dim1; - if (a[i__2].r != 0. || a[i__2].i != 0.) { - return ret_val; - } - } - } - } + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + ret_val * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + return ret_val; + } + } + } + } } return ret_val; } /* ilazlc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ilazlr.cpp b/lib/linalg/ilazlr.cpp index 8ca4fd8029..ebef3fa0e1 100644 --- a/lib/linalg/ilazlr.cpp +++ b/lib/linalg/ilazlr.cpp @@ -1,13 +1,13 @@ /* fortran/ilazlr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -128,32 +128,32 @@ integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda) /* Function Body */ if (*m == 0) { - ret_val = *m; + ret_val = *m; } else /* if(complicated condition) */ { - i__1 = *m + a_dim1; - i__2 = *m + *n * a_dim1; - if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] - .i != 0.)) { - ret_val = *m; - } else { + i__1 = *m + a_dim1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] + .i != 0.)) { + ret_val = *m; + } else { /* Scan up each column tracking the last zero row seen. */ - ret_val = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__ = *m; - for(;;) { /* while(complicated condition) */ - i__2 = max(i__,1) + j * a_dim1; - if (!(a[i__2].r == 0. && a[i__2].i == 0. && i__ >= 1)) - break; - --i__; - } - ret_val = max(ret_val,i__); - } - } + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + for(;;) { /* while(complicated condition) */ + i__2 = max(i__,1) + j * a_dim1; + if (!(a[i__2].r == 0. && a[i__2].i == 0. && i__ >= 1)) + break; + --i__; + } + ret_val = max(ret_val,i__); + } + } } return ret_val; } /* ilazlr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/iparmq.cpp b/lib/linalg/iparmq.cpp index 12f3b7f7f6..ad22d9f869 100644 --- a/lib/linalg/iparmq.cpp +++ b/lib/linalg/iparmq.cpp @@ -1,13 +1,13 @@ /* fortran/iparmq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -246,8 +246,8 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer - *ilo, integer *ihi, integer *lwork, ftnlen name_len, ftnlen opts_len) +integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer + *ilo, integer *ihi, integer *lwork, ftnlen name_len, ftnlen opts_len) { /* System generated locals */ integer ret_val, i__1, i__2; @@ -282,32 +282,32 @@ integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer /* ==== Set the number simultaneous shifts ==== */ - nh = *ihi - *ilo + 1; - ns = 2; - if (nh >= 30) { - ns = 4; - } - if (nh >= 60) { - ns = 10; - } - if (nh >= 150) { + nh = *ihi - *ilo + 1; + ns = 2; + if (nh >= 30) { + ns = 4; + } + if (nh >= 60) { + ns = 10; + } + if (nh >= 150) { /* Computing MAX */ - r__1 = log((real) nh) / log((float)2.); - i__1 = 10, i__2 = nh / i_nint(&r__1); - ns = max(i__1,i__2); - } - if (nh >= 590) { - ns = 64; - } - if (nh >= 3000) { - ns = 128; - } - if (nh >= 6000) { - ns = 256; - } + r__1 = log((real) nh) / log((float)2.); + i__1 = 10, i__2 = nh / i_nint(&r__1); + ns = max(i__1,i__2); + } + if (nh >= 590) { + ns = 64; + } + if (nh >= 3000) { + ns = 128; + } + if (nh >= 6000) { + ns = 256; + } /* Computing MAX */ - i__1 = 2, i__2 = ns - ns % 2; - ns = max(i__1,i__2); + i__1 = 2, i__2 = ns - ns % 2; + ns = max(i__1,i__2); } if (*ispec == 12) { @@ -317,7 +317,7 @@ integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer /* . to xLAHQR, the classic double shift algorithm. */ /* . This must be at least 11. ==== */ - ret_val = 75; + ret_val = 75; } else if (*ispec == 14) { @@ -325,23 +325,23 @@ integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer /* . whenever aggressive early deflation finds */ /* . at least (NIBBLE*(window size)/100) deflations. ==== */ - ret_val = 14; + ret_val = 14; } else if (*ispec == 15) { /* ==== NSHFTS: The number of simultaneous shifts ===== */ - ret_val = ns; + ret_val = ns; } else if (*ispec == 13) { /* ==== NW: deflation window size. ==== */ - if (nh <= 500) { - ret_val = ns; - } else { - ret_val = ns * 3 / 2; - } + if (nh <= 500) { + ret_val = ns; + } else { + ret_val = ns * 3 / 2; + } } else if (*ispec == 16) { @@ -355,87 +355,87 @@ integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer /* Convert NAME to upper case if the first character is lower case. */ - ret_val = 0; - s_copy(subnam, name__, (ftnlen)6, name_len); - ic = *(unsigned char *)subnam; - iz = 'Z'; - if (iz == 90 || iz == 122) { + ret_val = 0; + s_copy(subnam, name__, (ftnlen)6, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { /* ASCII character set */ - if (ic >= 97 && ic <= 122) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 97 && ic <= 122) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } - } - } + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } - } else if (iz == 233 || iz == 169) { + } else if (iz == 233 || iz == 169) { /* EBCDIC character set */ - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 - && ic <= 169) { - *(unsigned char *)subnam = (char) (ic + 64); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || - ic >= 162 && ic <= 169) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); - } - } - } + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 + && ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || + ic >= 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } + } + } - } else if (iz == 218 || iz == 250) { + } else if (iz == 218 || iz == 250) { /* Prime machines: ASCII+128 */ - if (ic >= 225 && ic <= 250) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 225 && ic <= 250) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } - } - } - } + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } + } - if (s_cmp(subnam + 1, (char *)"GGHRD", (ftnlen)5, (ftnlen)5) == 0 || s_cmp( - subnam + 1, (char *)"GGHD3", (ftnlen)5, (ftnlen)5) == 0) { - ret_val = 1; - if (nh >= 14) { - ret_val = 2; - } - } else if (s_cmp(subnam + 3, (char *)"EXC", (ftnlen)3, (ftnlen)3) == 0) { - if (nh >= 14) { - ret_val = 1; - } - if (nh >= 14) { - ret_val = 2; - } - } else if (s_cmp(subnam + 1, (char *)"HSEQR", (ftnlen)5, (ftnlen)5) == 0 || - s_cmp(subnam + 1, (char *)"LAQR", (ftnlen)4, (ftnlen)4) == 0) { - if (ns >= 14) { - ret_val = 1; - } - if (ns >= 14) { - ret_val = 2; - } - } + if (s_cmp(subnam + 1, (char *)"GGHRD", (ftnlen)5, (ftnlen)5) == 0 || s_cmp( + subnam + 1, (char *)"GGHD3", (ftnlen)5, (ftnlen)5) == 0) { + ret_val = 1; + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 3, (char *)"EXC", (ftnlen)3, (ftnlen)3) == 0) { + if (nh >= 14) { + ret_val = 1; + } + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 1, (char *)"HSEQR", (ftnlen)5, (ftnlen)5) == 0 || + s_cmp(subnam + 1, (char *)"LAQR", (ftnlen)4, (ftnlen)4) == 0) { + if (ns >= 14) { + ret_val = 1; + } + if (ns >= 14) { + ret_val = 2; + } + } } else if (*ispec == 17) { /* === Relative cost of near-the-diagonal chase vs */ /* BLAS updates === */ - ret_val = 10; + ret_val = 10; } else { /* ===== invalid value of ispec ===== */ - ret_val = -1; + ret_val = -1; } @@ -445,5 +445,5 @@ integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer } /* iparmq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/lmp_f2c.h b/lib/linalg/lmp_f2c.h index 0b1ebac99c..7483a147ea 100644 --- a/lib/linalg/lmp_f2c.h +++ b/lib/linalg/lmp_f2c.h @@ -2,7 +2,7 @@ /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ #ifndef F2C_INCLUDE #define F2C_INCLUDE @@ -19,11 +19,11 @@ typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; -#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ -typedef long long longint; /* system-dependent */ -typedef unsigned long long ulongint; /* system-dependent */ -#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) -#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) #endif #define TRUE_ (1) @@ -49,109 +49,109 @@ typedef long int ftnint; /*external read, write*/ typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; } cilist; /*internal read, write*/ typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; } icilist; /*open*/ typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; } olist; /*close*/ typedef struct -{ flag cerr; - ftnint cunit; - char *csta; +{ flag cerr; + ftnint cunit; + char *csta; } cllist; /*rewind, backspace, endfile*/ typedef struct -{ flag aerr; - ftnint aunit; +{ flag aerr; + ftnint aunit; } alist; /* inquire */ typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; } inlist; #define VOID void -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; typedef union Multitype Multitype; -/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; typedef struct Vardesc Vardesc; struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; + char *name; + Vardesc **vars; + int nvars; + }; typedef struct Namelist Namelist; #define abs(x) ((x) >= 0 ? (x) : -(x)) @@ -160,9 +160,9 @@ typedef struct Namelist Namelist; #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) /* procedure parameter types for -A and -C++ */ @@ -193,10 +193,10 @@ typedef /* Character */ VOID (*H_fp)(); typedef /* Subroutine */ int (*S_fp)(); #endif /* E_fp is for real functions when -R is not specified */ -typedef VOID C_f; /* complex function */ -typedef VOID H_f; /* character function */ -typedef VOID Z_f; /* double complex function */ -typedef doublereal E_f; /* real function with -R not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ diff --git a/lib/linalg/zaxpy.cpp b/lib/linalg/zaxpy.cpp index 2788743a40..6939872757 100644 --- a/lib/linalg/zaxpy.cpp +++ b/lib/linalg/zaxpy.cpp @@ -1,13 +1,13 @@ /* fortran/zaxpy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -101,8 +101,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx, - integer *incx, doublecomplex *zy, integer *incy) +/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx, + integer *incx, doublecomplex *zy, integer *incy) { /* System generated locals */ integer i__1, i__2, i__3, i__4; @@ -134,50 +134,50 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (dcabs1_(za) == 0.) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - i__4 = i__; - z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * - zx[i__4].i + za->i * zx[i__4].r; - z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; - zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * + zx[i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - i__4 = ix; - z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * - zx[i__4].i + za->i * zx[i__4].r; - z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; - zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + i__4 = ix; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * + zx[i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + ix += *incx; + iy += *incy; + } } return 0; @@ -187,5 +187,5 @@ extern "C" { } /* zaxpy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zcopy.cpp b/lib/linalg/zcopy.cpp index 357bd961a0..97d1250228 100644 --- a/lib/linalg/zcopy.cpp +++ b/lib/linalg/zcopy.cpp @@ -1,13 +1,13 @@ /* fortran/zcopy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -94,8 +94,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx, - doublecomplex *zy, integer *incy) +/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy) { /* System generated locals */ integer i__1, i__2, i__3; @@ -123,39 +123,39 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = ix; - zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = ix; + zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; + ix += *incx; + iy += *incy; + } } return 0; @@ -164,5 +164,5 @@ extern "C" { } /* zcopy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zdotc.cpp b/lib/linalg/zdotc.cpp index 943f923bea..e0c614e843 100644 --- a/lib/linalg/zdotc.cpp +++ b/lib/linalg/zdotc.cpp @@ -1,13 +1,13 @@ /* fortran/zdotc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -96,8 +96,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n, - doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy) +/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n, + doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy) { /* System generated locals */ integer i__1, i__2; @@ -134,45 +134,45 @@ extern "C" { ztemp.r = 0., ztemp.i = 0.; ret_val->r = 0., ret_val->i = 0.; if (*n <= 0) { - return ; + return ; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d_cnjg(&z__3, &zx[i__]); - i__2 = i__; - z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = - z__3.r * zy[i__2].i + z__3.i * zy[i__2].r; - z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; - ztemp.r = z__1.r, ztemp.i = z__1.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d_cnjg(&z__3, &zx[i__]); + i__2 = i__; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = + z__3.r * zy[i__2].i + z__3.i * zy[i__2].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; + } } else { /* code for unequal increments or equal increments */ /* not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d_cnjg(&z__3, &zx[ix]); - i__2 = iy; - z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = - z__3.r * zy[i__2].i + z__3.i * zy[i__2].r; - z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; - ztemp.r = z__1.r, ztemp.i = z__1.i; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d_cnjg(&z__3, &zx[ix]); + i__2 = iy; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = + z__3.r * zy[i__2].i + z__3.i * zy[i__2].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; + ix += *incx; + iy += *incy; + } } ret_val->r = ztemp.r, ret_val->i = ztemp.i; return ; @@ -182,5 +182,5 @@ extern "C" { } /* zdotc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zdrot.cpp b/lib/linalg/zdrot.cpp index c6ec16b053..e4c66f5480 100644 --- a/lib/linalg/zdrot.cpp +++ b/lib/linalg/zdrot.cpp @@ -1,13 +1,13 @@ /* fortran/zdrot.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -111,8 +111,8 @@ extern "C" { /* > \ingroup complex16_blas_level1 */ /* ===================================================================== */ -/* Subroutine */ int zdrot_(integer *n, doublecomplex *zx, integer *incx, - doublecomplex *zy, integer *incy, doublereal *c__, doublereal *s) +/* Subroutine */ int zdrot_(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy, doublereal *c__, doublereal *s) { /* System generated locals */ integer i__1, i__2, i__3, i__4; @@ -144,63 +144,63 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; - i__3 = i__; - z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - ctemp.r = z__1.r, ctemp.i = z__1.i; - i__2 = i__; - i__3 = i__; - z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; - i__4 = i__; - z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; - zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; - i__2 = i__; - zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; + i__3 = i__; + z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = i__; + i__3 = i__; + z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; + i__4 = i__; + z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + i__2 = i__; + zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.i; + } } else { /* code for unequal increments or equal increments not equal */ /* to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = ix; - z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; - i__3 = iy; - z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - ctemp.r = z__1.r, ctemp.i = z__1.i; - i__2 = iy; - i__3 = iy; - z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; - i__4 = ix; - z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; - zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; - i__2 = ix; - zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.i; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; + i__3 = iy; + z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = iy; + i__3 = iy; + z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; + i__4 = ix; + z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + i__2 = ix; + zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; + } } return 0; @@ -209,5 +209,5 @@ extern "C" { } /* zdrot_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zdscal.cpp b/lib/linalg/zdscal.cpp index c7c6406782..fd444bdf71 100644 --- a/lib/linalg/zdscal.cpp +++ b/lib/linalg/zdscal.cpp @@ -1,13 +1,13 @@ /* fortran/zdscal.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -91,8 +91,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx, - integer *incx) +/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx, + integer *incx) { /* System generated locals */ integer i__1, i__2, i__3, i__4; @@ -127,36 +127,36 @@ extern "C" { /* Function Body */ if (*n <= 0 || *incx <= 0 || *da == 1.) { - return 0; + return 0; } if (*incx == 1) { /* code for increment equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - d__1 = *da * zx[i__3].r; - d__2 = *da * d_imag(&zx[i__]); - z__1.r = d__1, z__1.i = d__2; - zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + d__1 = *da * zx[i__3].r; + d__2 = *da * d_imag(&zx[i__]); + z__1.r = d__1, z__1.i = d__2; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + } } else { /* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - i__3 = i__; - i__4 = i__; - d__1 = *da * zx[i__4].r; - d__2 = *da * d_imag(&zx[i__]); - z__1.r = d__1, z__1.i = d__2; - zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; - } + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + d__1 = *da * zx[i__4].r; + d__2 = *da * d_imag(&zx[i__]); + z__1.r = d__1, z__1.i = d__2; + zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; + } } return 0; @@ -165,5 +165,5 @@ extern "C" { } /* zdscal_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zgemm.cpp b/lib/linalg/zgemm.cpp index 92434e720f..53020bef2d 100644 --- a/lib/linalg/zgemm.cpp +++ b/lib/linalg/zgemm.cpp @@ -1,13 +1,13 @@ /* fortran/zgemm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -201,13 +201,13 @@ extern "C" { /* > */ /* ===================================================================== */ /* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer * - n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda, - doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex * - c__, integer *ldc, ftnlen transa_len, ftnlen transb_len) + n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda, + doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex * + c__, integer *ldc, ftnlen transa_len, ftnlen transb_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6; + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ @@ -267,489 +267,489 @@ extern "C" { conja = lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1); conjb = lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1); if (nota) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *k; + nrowa = *k; } if (notb) { - nrowb = *k; + nrowb = *k; } else { - nrowb = *n; + nrowb = *n; } /* Test the input parameters. */ info = 0; if (! nota && ! conja && ! lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { - info = 1; + info = 1; } else if (! notb && ! conjb && ! lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen) - 1)) { - info = 2; + 1)) { + info = 2; } else if (*m < 0) { - info = 3; + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*k < 0) { - info = 5; + info = 5; } else if (*lda < max(1,nrowa)) { - info = 8; + info = 8; } else if (*ldb < max(1,nrowb)) { - info = 10; + info = 10; } else if (*ldc < max(1,*m)) { - info = 13; + info = 13; } if (info != 0) { - xerbla_((char *)"ZGEMM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZGEMM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && - (beta->r == 1. && beta->i == 0.)) { - return 0; + (beta->r == 1. && beta->i == 0.)) { + return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0. && alpha->i == 0.) { - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, - z__1.i = beta->r * c__[i__4].i + beta->i * c__[ - i__4].r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L30: */ - } + } /* L40: */ - } - } - return 0; + } + } + return 0; } /* Start the operations. */ if (notb) { - if (nota) { + if (nota) { /* Form C := alpha*A*B + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (beta->r == 0. && beta->i == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L50: */ - } - } else if (beta->r != 1. || beta->i != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__1.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L60: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - i__3 = l + j * b_dim1; - z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, - z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] - .r; - temp.r = z__1.r, temp.i = z__1.i; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * c_dim1; - i__6 = i__ + l * a_dim1; - z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, - z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] - .r; - z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + - z__2.i; - c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L70: */ - } + } /* L80: */ - } + } /* L90: */ - } - } else if (conja) { + } + } else if (conja) { /* Form C := alpha*A**H*B + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - d_cnjg(&z__3, &a[l + i__ * a_dim1]); - i__4 = l + j * b_dim1; - z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, - z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] - .r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L100: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L110: */ - } + } /* L120: */ - } - } else { + } + } else { /* Form C := alpha*A**T*B + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - i__4 = l + i__ * a_dim1; - i__5 = l + j * b_dim1; - z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] - .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] - .i * b[i__5].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L130: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L140: */ - } + } /* L150: */ - } - } + } + } } else if (nota) { - if (conjb) { + if (conjb) { /* Form C := alpha*A*B**H + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (beta->r == 0. && beta->i == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L160: */ - } - } else if (beta->r != 1. || beta->i != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__1.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L170: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - d_cnjg(&z__2, &b[j + l * b_dim1]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * c_dim1; - i__6 = i__ + l * a_dim1; - z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, - z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] - .r; - z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + - z__2.i; - c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L180: */ - } + } /* L190: */ - } + } /* L200: */ - } - } else { + } + } else { /* Form C := alpha*A*B**T + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (beta->r == 0. && beta->i == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L210: */ - } - } else if (beta->r != 1. || beta->i != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__1.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L220: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - i__3 = j + l * b_dim1; - z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, - z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] - .r; - temp.r = z__1.r, temp.i = z__1.i; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * c_dim1; - i__6 = i__ + l * a_dim1; - z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, - z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] - .r; - z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + - z__2.i; - c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L230: */ - } + } /* L240: */ - } + } /* L250: */ - } - } + } + } } else if (conja) { - if (conjb) { + if (conjb) { /* Form C := alpha*A**H*B**H + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - d_cnjg(&z__3, &a[l + i__ * a_dim1]); - d_cnjg(&z__4, &b[j + l * b_dim1]); - z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = - z__3.r * z__4.i + z__3.i * z__4.r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + d_cnjg(&z__4, &b[j + l * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = + z__3.r * z__4.i + z__3.i * z__4.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L260: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L270: */ - } + } /* L280: */ - } - } else { + } + } else { /* Form C := alpha*A**H*B**T + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - d_cnjg(&z__3, &a[l + i__ * a_dim1]); - i__4 = j + l * b_dim1; - z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, - z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] - .r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = j + l * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L290: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L300: */ - } + } /* L310: */ - } - } + } + } } else { - if (conjb) { + if (conjb) { /* Form C := alpha*A**T*B**H + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - i__4 = l + i__ * a_dim1; - d_cnjg(&z__3, &b[j + l * b_dim1]); - z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i, - z__2.i = a[i__4].r * z__3.i + a[i__4].i * - z__3.r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + d_cnjg(&z__3, &b[j + l * b_dim1]); + z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i, + z__2.i = a[i__4].r * z__3.i + a[i__4].i * + z__3.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L320: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L330: */ - } + } /* L340: */ - } - } else { + } + } else { /* Form C := alpha*A**T*B**T + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp.r = 0., temp.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - i__4 = l + i__ * a_dim1; - i__5 = j + l * b_dim1; - z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] - .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] - .i * b[i__5].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L350: */ - } - if (beta->r == 0. && beta->i == 0.) { - i__3 = i__ + j * c_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, - z__2.i = alpha->r * temp.i + alpha->i * - temp.r; - i__4 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] - .i, z__3.i = beta->r * c__[i__4].i + beta->i * - c__[i__4].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } /* L360: */ - } + } /* L370: */ - } - } + } + } } return 0; @@ -759,5 +759,5 @@ extern "C" { } /* zgemm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zgemv.cpp b/lib/linalg/zgemv.cpp index 9524445dba..99b8cf9d0a 100644 --- a/lib/linalg/zgemv.cpp +++ b/lib/linalg/zgemv.cpp @@ -1,13 +1,13 @@ /* fortran/zgemv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -171,10 +171,10 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n, - doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * - x, integer *incx, doublecomplex *beta, doublecomplex *y, integer * - incy, ftnlen trans_len) +/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + x, integer *incx, doublecomplex *beta, doublecomplex *y, integer * + incy, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -226,30 +226,30 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"T", ( - ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1) - ) { - info = 1; + ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1) + ) { + info = 1; } else if (*m < 0) { - info = 2; + info = 2; } else if (*n < 0) { - info = 3; + info = 3; } else if (*lda < max(1,*m)) { - info = 6; + info = 6; } else if (*incx == 0) { - info = 8; + info = 8; } else if (*incy == 0) { - info = 11; + info = 11; } if (info != 0) { - xerbla_((char *)"ZGEMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZGEMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ - if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == - 1. && beta->i == 0.)) { - return 0; + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == + 1. && beta->i == 0.)) { + return 0; } noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); @@ -258,21 +258,21 @@ extern "C" { /* up the start points in X and Y. */ if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - lenx = *n; - leny = *m; + lenx = *n; + leny = *m; } else { - lenx = *m; - leny = *n; + lenx = *m; + leny = *n; } if (*incx > 0) { - kx = 1; + kx = 1; } else { - kx = 1 - (lenx - 1) * *incx; + kx = 1 - (lenx - 1) * *incx; } if (*incy > 0) { - ky = 1; + ky = 1; } else { - ky = 1 - (leny - 1) * *incy; + ky = 1 - (leny - 1) * *incy; } /* Start the operations. In this version the elements of A are */ @@ -281,189 +281,189 @@ extern "C" { /* First form y := beta*y. */ if (beta->r != 1. || beta->i != 0.) { - if (*incy == 1) { - if (beta->r == 0. && beta->i == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0., y[i__2].i = 0.; + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; /* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; /* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0. && beta->i == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0., y[i__2].i = 0.; - iy += *incy; + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; /* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; /* L40: */ - } - } - } + } + } + } } if (alpha->r == 0. && alpha->i == 0.) { - return 0; + return 0; } if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form y := alpha*A*x + y. */ - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = - temp.r * a[i__5].i + temp.i * a[i__5].r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = + temp.r * a[i__5].i + temp.i * a[i__5].r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; /* L50: */ - } - jx += *incx; + } + jx += *incx; /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - iy = ky; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = iy; - i__4 = iy; - i__5 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = - temp.r * a[i__5].i + temp.i * a[i__5].r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - iy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, z__2.i = + temp.r * a[i__5].i + temp.i * a[i__5].r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + iy += *incy; /* L70: */ - } - jx += *incx; + } + jx += *incx; /* L80: */ - } - } + } + } } else { /* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. */ - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp.r = 0., temp.i = 0.; - if (noconj) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__; - z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] - .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] - .i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L90: */ - } - } else { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] - .r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L100: */ - } - } - i__2 = jy; - i__3 = jy; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = - alpha->r * temp.i + alpha->i * temp.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jy += *incy; + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jy += *incy; /* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp.r = 0., temp.i = 0.; - ix = kx; - if (noconj) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = ix; - z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] - .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] - .i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + ix = kx; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; /* L120: */ - } - } else { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] - .r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; /* L130: */ - } - } - i__2 = jy; - i__3 = jy; - z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = - alpha->r * temp.i + alpha->i * temp.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jy += *incy; + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jy += *incy; /* L140: */ - } - } + } + } } return 0; @@ -473,5 +473,5 @@ extern "C" { } /* zgemv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zgerc.cpp b/lib/linalg/zgerc.cpp index db1e60a2eb..668c4c4f64 100644 --- a/lib/linalg/zgerc.cpp +++ b/lib/linalg/zgerc.cpp @@ -1,13 +1,13 @@ /* fortran/zgerc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -143,9 +143,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha, - doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, - doublecomplex *a, integer *lda) +/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *a, integer *lda) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -192,90 +192,90 @@ extern "C" { /* Function Body */ info = 0; if (*m < 0) { - info = 1; + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*incx == 0) { - info = 5; + info = 5; } else if (*incy == 0) { - info = 7; + info = 7; } else if (*lda < max(1,*m)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"ZGERC ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZGERC ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) { - return 0; + return 0; } /* Start the operations. In this version the elements of A are */ /* accessed sequentially with one pass through A. */ if (*incy > 0) { - jy = 1; + jy = 1; } else { - jy = 1 - (*n - 1) * *incy; + jy = 1 - (*n - 1) * *incy; } if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jy; - if (y[i__2].r != 0. || y[i__2].i != 0.) { - d_cnjg(&z__2, &y[jy]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = i__; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = - x[i__5].r * temp.i + x[i__5].i * temp.r; - z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L10: */ - } - } - jy += *incy; + } + } + jy += *incy; /* L20: */ - } + } } else { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*m - 1) * *incx; - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jy; - if (y[i__2].r != 0. || y[i__2].i != 0.) { - d_cnjg(&z__2, &y[jy]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = ix; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = - x[i__5].r * temp.i + x[i__5].i * temp.r; - z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - ix += *incx; + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; /* L30: */ - } - } - jy += *incy; + } + } + jy += *incy; /* L40: */ - } + } } return 0; @@ -285,5 +285,5 @@ extern "C" { } /* zgerc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zheev.cpp b/lib/linalg/zheev.cpp index f421e49090..52661d9511 100644 --- a/lib/linalg/zheev.cpp +++ b/lib/linalg/zheev.cpp @@ -1,13 +1,13 @@ /* fortran/zheev.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -163,9 +163,9 @@ ices */ /* > \ingroup complex16HEeigen */ /* ===================================================================== */ -/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex - *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork, - doublereal *rwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) +/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex + *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork, + doublereal *rwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -181,8 +181,8 @@ ices */ doublereal anrm; integer imax; doublereal rmin, rmax; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal sigma; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo; @@ -190,29 +190,29 @@ ices */ extern doublereal dlamch_(char *, ftnlen); integer iscale; doublereal safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal bignum; - extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, - integer *, doublereal *, ftnlen, ftnlen); + extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, + integer *, doublereal *, ftnlen, ftnlen); integer indtau; extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *), zlascl_(char *, integer *, integer *, doublereal *, - doublereal *, integer *, integer *, doublecomplex *, integer *, - integer *, ftnlen); + integer *), zlascl_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, integer *, doublecomplex *, integer *, + integer *, ftnlen); integer indwrk; - extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, - integer *, doublereal *, doublereal *, doublecomplex *, - doublecomplex *, integer *, integer *, ftnlen); + extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, + doublecomplex *, integer *, integer *, ftnlen); integer llwork; doublereal smlnum; integer lwkopt; logical lquery; - extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *, - doublereal *, doublecomplex *, integer *, doublereal *, integer *, - ftnlen), zungtr_(char *, integer *, doublecomplex *, integer *, - doublecomplex *, doublecomplex *, integer *, integer *, ftnlen); + extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublereal *, integer *, + ftnlen), zungtr_(char *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *, ftnlen); /* -- LAPACK driver routine -- */ @@ -255,53 +255,53 @@ ices */ *info = 0; if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -1; + *info = -1; } else if (! (lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info == 0) { - nb = ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); + nb = ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); /* Computing MAX */ - i__1 = 1, i__2 = (nb + 1) * *n; - lwkopt = max(i__1,i__2); - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + i__1 = 1, i__2 = (nb + 1) * *n; + lwkopt = max(i__1,i__2); + work[1].r = (doublereal) lwkopt, work[1].i = 0.; /* Computing MAX */ - i__1 = 1, i__2 = (*n << 1) - 1; - if (*lwork < max(i__1,i__2) && ! lquery) { - *info = -8; - } + i__1 = 1, i__2 = (*n << 1) - 1; + if (*lwork < max(i__1,i__2) && ! lquery) { + *info = -8; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZHEEV ", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZHEEV ", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - i__1 = a_dim1 + 1; - w[1] = a[i__1].r; - work[1].r = 1., work[1].i = 0.; - if (wantz) { - i__1 = a_dim1 + 1; - a[i__1].r = 1., a[i__1].i = 0.; - } - return 0; + i__1 = a_dim1 + 1; + w[1] = a[i__1].r; + work[1].r = 1., work[1].i = 0.; + if (wantz) { + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + } + return 0; } /* Get machine constants. */ @@ -316,18 +316,18 @@ ices */ /* Scale matrix to allowable range, if necessary. */ anrm = zlanhe_((char *)"M", uplo, n, &a[a_offset], lda, &rwork[1], (ftnlen)1, ( - ftnlen)1); + ftnlen)1); iscale = 0; if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; + iscale = 1; + sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; + iscale = 1; + sigma = rmax / anrm; } if (iscale == 1) { - zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, - info, (ftnlen)1); + zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, + info, (ftnlen)1); } /* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */ @@ -337,31 +337,31 @@ ices */ indwrk = indtau + *n; llwork = *lwork - indwrk + 1; zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo, (ftnlen)1); + work[indwrk], &llwork, &iinfo, (ftnlen)1); /* For eigenvalues only, call DSTERF. For eigenvectors, first call */ /* ZUNGTR to generate the unitary matrix, then call ZSTEQR. */ if (! wantz) { - dsterf_(n, &w[1], &rwork[inde], info); + dsterf_(n, &w[1], &rwork[inde], info); } else { - zungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & - llwork, &iinfo, (ftnlen)1); - indwrk = inde + *n; - zsteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[ - indwrk], info, (ftnlen)1); + zungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & + llwork, &iinfo, (ftnlen)1); + indwrk = inde + *n; + zsteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[ + indwrk], info, (ftnlen)1); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); } /* Set WORK(1) to optimal complex workspace size. */ @@ -375,5 +375,5 @@ ices */ } /* zheev_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zheevd.cpp b/lib/linalg/zheevd.cpp index c340c17718..83747a7962 100644 --- a/lib/linalg/zheevd.cpp +++ b/lib/linalg/zheevd.cpp @@ -1,13 +1,13 @@ /* fortran/zheevd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -228,10 +228,10 @@ f"> */ /* > at Berkeley, USA */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, - integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) +/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n, + doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, + integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -247,8 +247,8 @@ f"> */ integer imax; doublereal rmin, rmax; integer lopt; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); doublereal sigma; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer iinfo, lwmin, liopt; @@ -259,33 +259,33 @@ f"> */ extern doublereal dlamch_(char *, ftnlen); integer iscale; doublereal safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); doublereal bignum; - extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, - integer *, doublereal *, ftnlen, ftnlen); + extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, + integer *, doublereal *, ftnlen, ftnlen); integer indtau; extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *), zlascl_(char *, integer *, integer *, doublereal *, - doublereal *, integer *, integer *, doublecomplex *, integer *, - integer *, ftnlen), zstedc_(char *, integer *, doublereal *, - doublereal *, doublecomplex *, integer *, doublecomplex *, - integer *, doublereal *, integer *, integer *, integer *, integer - *, ftnlen); + integer *), zlascl_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, integer *, doublecomplex *, integer *, + integer *, ftnlen), zstedc_(char *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublecomplex *, + integer *, doublereal *, integer *, integer *, integer *, integer + *, ftnlen); integer indrwk, indwrk, liwmin; - extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, - integer *, doublereal *, doublereal *, doublecomplex *, - doublecomplex *, integer *, integer *, ftnlen), zlacpy_(char *, - integer *, integer *, doublecomplex *, integer *, doublecomplex *, - integer *, ftnlen); + extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, + doublecomplex *, integer *, integer *, ftnlen), zlacpy_(char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, ftnlen); integer lrwmin, llwork; doublereal smlnum; logical lquery; - extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, integer *, - ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *, + ftnlen, ftnlen, ftnlen); /* -- LAPACK driver routine -- */ @@ -329,77 +329,77 @@ f"> */ *info = 0; if (! (wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { - *info = -1; + *info = -1; } else if (! (lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } else if (*lda < max(1,*n)) { - *info = -5; + *info = -5; } if (*info == 0) { - if (*n <= 1) { - lwmin = 1; - lrwmin = 1; - liwmin = 1; - lopt = lwmin; - lropt = lrwmin; - liopt = liwmin; - } else { - if (wantz) { - lwmin = (*n << 1) + *n * *n; + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + lopt = lwmin; + lropt = lrwmin; + liopt = liwmin; + } else { + if (wantz) { + lwmin = (*n << 1) + *n * *n; /* Computing 2nd power */ - i__1 = *n; - lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); - liwmin = *n * 5 + 3; - } else { - lwmin = *n + 1; - lrwmin = *n; - liwmin = 1; - } + i__1 = *n; + lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } else { + lwmin = *n + 1; + lrwmin = *n; + liwmin = 1; + } /* Computing MAX */ - i__1 = lwmin, i__2 = *n + *n * ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, & - c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - lopt = max(i__1,i__2); - lropt = lrwmin; - liopt = liwmin; - } - work[1].r = (doublereal) lopt, work[1].i = 0.; - rwork[1] = (doublereal) lropt; - iwork[1] = liopt; + i__1 = lwmin, i__2 = *n + *n * ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, & + c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lopt = max(i__1,i__2); + lropt = lrwmin; + liopt = liwmin; + } + work[1].r = (doublereal) lopt, work[1].i = 0.; + rwork[1] = (doublereal) lropt; + iwork[1] = liopt; - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*lrwork < lrwmin && ! lquery) { - *info = -10; - } else if (*liwork < liwmin && ! lquery) { - *info = -12; - } + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*lrwork < lrwmin && ! lquery) { + *info = -10; + } else if (*liwork < liwmin && ! lquery) { + *info = -12; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZHEEVD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZHEEVD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - i__1 = a_dim1 + 1; - w[1] = a[i__1].r; - if (wantz) { - i__1 = a_dim1 + 1; - a[i__1].r = 1., a[i__1].i = 0.; - } - return 0; + i__1 = a_dim1 + 1; + w[1] = a[i__1].r; + if (wantz) { + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + } + return 0; } /* Get machine constants. */ @@ -414,18 +414,18 @@ f"> */ /* Scale matrix to allowable range, if necessary. */ anrm = zlanhe_((char *)"M", uplo, n, &a[a_offset], lda, &rwork[1], (ftnlen)1, ( - ftnlen)1); + ftnlen)1); iscale = 0; if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; + iscale = 1; + sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; + iscale = 1; + sigma = rmax / anrm; } if (iscale == 1) { - zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, - info, (ftnlen)1); + zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, + info, (ftnlen)1); } /* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */ @@ -439,7 +439,7 @@ f"> */ llwrk2 = *lwork - indwk2 + 1; llrwk = *lrwork - indrwk + 1; zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo, (ftnlen)1); + work[indwrk], &llwork, &iinfo, (ftnlen)1); /* For eigenvalues only, call DSTERF. For eigenvectors, first call */ /* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ @@ -448,27 +448,27 @@ f"> */ /* A. */ if (! wantz) { - dsterf_(n, &w[1], &rwork[inde], info); + dsterf_(n, &w[1], &rwork[inde], info); } else { - zstedc_((char *)"I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2], - &llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info, ( - ftnlen)1); - zunmtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[ - indwrk], n, &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - zlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); + zstedc_((char *)"I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2], + &llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info, ( + ftnlen)1); + zunmtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[ + indwrk], n, &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + zlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); } work[1].r = (doublereal) lopt, work[1].i = 0.; @@ -482,5 +482,5 @@ f"> */ } /* zheevd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zhemv.cpp b/lib/linalg/zhemv.cpp index f965dcfcdf..132915183b 100644 --- a/lib/linalg/zhemv.cpp +++ b/lib/linalg/zhemv.cpp @@ -1,13 +1,13 @@ /* fortran/zhemv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -167,9 +167,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, - doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen uplo_len) +/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, + doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -220,40 +220,40 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*lda < max(1,*n)) { - info = 5; + info = 5; } else if (*incx == 0) { - info = 7; + info = 7; } else if (*incy == 0) { - info = 10; + info = 10; } if (info != 0) { - xerbla_((char *)"ZHEMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZHEMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ - if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && - beta->i == 0.)) { - return 0; + if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && + beta->i == 0.)) { + return 0; } /* Set up the start points in X and Y. */ if (*incx > 0) { - kx = 1; + kx = 1; } else { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } if (*incy > 0) { - ky = 1; + ky = 1; } else { - ky = 1 - (*n - 1) * *incy; + ky = 1 - (*n - 1) * *incy; } /* Start the operations. In this version the elements of A are */ @@ -263,238 +263,238 @@ extern "C" { /* First form y := beta*y. */ if (beta->r != 1. || beta->i != 0.) { - if (*incy == 1) { - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0., y[i__2].i = 0.; + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; /* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; /* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0., y[i__2].i = 0.; - iy += *incy; + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; /* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; /* L40: */ - } - } - } + } + } + } } if (alpha->r == 0. && alpha->i == 0.) { - return 0; + return 0; } if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { /* Form y when A is stored in upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; /* L50: */ - } - i__2 = j; - i__3 = j; - i__4 = j + j * a_dim1; - d__1 = a[i__4].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; /* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = iy; - i__4 = iy; - i__5 = i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; - ix += *incx; - iy += *incy; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ix += *incx; + iy += *incy; /* L70: */ - } - i__2 = jy; - i__3 = jy; - i__4 = j + j * a_dim1; - d__1 = a[i__4].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jx += *incx; - jy += *incy; + } + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; /* L80: */ - } - } + } + } } else { /* Form y when A is stored in lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__2 = j; - i__3 = j; - i__4 = j + j * a_dim1; - d__1 = a[i__4].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; /* L90: */ - } - i__2 = j; - i__3 = j; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; + } + i__2 = j; + i__3 = j; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; /* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__2 = jy; - i__3 = jy; - i__4 = j + j * a_dim1; - d__1 = a[i__4].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - i__3 = iy; - i__4 = iy; - i__5 = i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; /* L110: */ - } - i__2 = jy; - i__3 = jy; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jx += *incx; - jy += *incy; + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; /* L120: */ - } - } + } + } } return 0; @@ -504,5 +504,5 @@ extern "C" { } /* zhemv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zher2.cpp b/lib/linalg/zher2.cpp index 2f77acd257..07d95f7917 100644 --- a/lib/linalg/zher2.cpp +++ b/lib/linalg/zher2.cpp @@ -1,13 +1,13 @@ /* fortran/zher2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -163,9 +163,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, - doublecomplex *a, integer *lda, ftnlen uplo_len) +/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *a, integer *lda, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; @@ -216,44 +216,44 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*incx == 0) { - info = 5; + info = 5; } else if (*incy == 0) { - info = 7; + info = 7; } else if (*lda < max(1,*n)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"ZHER2 ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZHER2 ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || alpha->r == 0. && alpha->i == 0.) { - return 0; + return 0; } /* Set up the start points in X and Y if the increments are not both */ /* unity. */ if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; } /* Start the operations. In this version the elements of A are */ @@ -264,248 +264,248 @@ extern "C" { /* Form A when A is stored in the upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - i__3 = j; - if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || - y[i__3].i != 0.)) { - d_cnjg(&z__2, &y[j]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__2 = j; - z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, - z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] - .r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = i__; - z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, - z__3.i = x[i__5].r * temp1.i + x[i__5].i * - temp1.r; - z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + - z__3.i; - i__6 = i__; - z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, - z__4.i = y[i__6].r * temp2.i + y[i__6].i * - temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L10: */ - } - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - i__4 = j; - z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, - z__2.i = x[i__4].r * temp1.i + x[i__4].i * - temp1.r; - i__5 = j; - z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, - z__3.i = y[i__5].r * temp2.i + y[i__5].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = a[i__3].r + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - } else { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - i__3 = jy; - if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || - y[i__3].i != 0.)) { - d_cnjg(&z__2, &y[jy]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__2 = jx; - z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, - z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] - .r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = ix; - z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, - z__3.i = x[i__5].r * temp1.i + x[i__5].i * - temp1.r; - z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + - z__3.i; - i__6 = iy; - z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, - z__4.i = y[i__6].r * temp2.i + y[i__6].i * - temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - ix += *incx; - iy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; + iy += *incy; /* L30: */ - } - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - i__4 = jx; - z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, - z__2.i = x[i__4].r * temp1.i + x[i__4].i * - temp1.r; - i__5 = jy; - z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, - z__3.i = y[i__5].r * temp2.i + y[i__5].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = a[i__3].r + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - } else { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } - jx += *incx; - jy += *incy; + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; + jy += *incy; /* L40: */ - } - } + } + } } else { /* Form A when A is stored in the lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - i__3 = j; - if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || - y[i__3].i != 0.)) { - d_cnjg(&z__2, &y[j]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__2 = j; - z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, - z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] - .r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - i__4 = j; - z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, - z__2.i = x[i__4].r * temp1.i + x[i__4].i * - temp1.r; - i__5 = j; - z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, - z__3.i = y[i__5].r * temp2.i + y[i__5].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = a[i__3].r + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = i__; - z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, - z__3.i = x[i__5].r * temp1.i + x[i__5].i * - temp1.r; - z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + - z__3.i; - i__6 = i__; - z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, - z__4.i = y[i__6].r * temp2.i + y[i__6].i * - temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ - } - } else { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - i__3 = jy; - if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || - y[i__3].i != 0.)) { - d_cnjg(&z__2, &y[jy]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = - alpha->r * z__2.i + alpha->i * z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__2 = jx; - z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, - z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] - .r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - i__4 = jx; - z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, - z__2.i = x[i__4].r * temp1.i + x[i__4].i * - temp1.r; - i__5 = jy; - z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, - z__3.i = y[i__5].r * temp2.i + y[i__5].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = a[i__3].r + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - i__5 = ix; - z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, - z__3.i = x[i__5].r * temp1.i + x[i__5].i * - temp1.r; - z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + - z__3.i; - i__6 = iy; - z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, - z__4.i = y[i__6].r * temp2.i + y[i__6].i * - temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L70: */ - } - } else { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } - jx += *incx; - jy += *incy; + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; + jy += *incy; /* L80: */ - } - } + } + } } return 0; @@ -515,5 +515,5 @@ extern "C" { } /* zher2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zher2k.cpp b/lib/linalg/zher2k.cpp index 1b94010d33..7b5553add1 100644 --- a/lib/linalg/zher2k.cpp +++ b/lib/linalg/zher2k.cpp @@ -1,13 +1,13 @@ /* fortran/zher2k.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -211,14 +211,14 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k, - doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * - b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc, - ftnlen uplo_len, ftnlen trans_len) +/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc, + ftnlen uplo_len, ftnlen trans_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; @@ -271,108 +271,108 @@ extern "C" { /* Function Body */ if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - nrowa = *n; + nrowa = *n; } else { - nrowa = *k; + nrowa = *k; } upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); info = 0; if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"C", (ftnlen)1, (ftnlen)1)) { - info = 2; + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"C", (ftnlen)1, (ftnlen)1)) { + info = 2; } else if (*n < 0) { - info = 3; + info = 3; } else if (*k < 0) { - info = 4; + info = 4; } else if (*lda < max(1,nrowa)) { - info = 7; + info = 7; } else if (*ldb < max(1,nrowa)) { - info = 9; + info = 9; } else if (*ldc < max(1,*n)) { - info = 12; + info = 12; } if (info != 0) { - xerbla_((char *)"ZHER2K", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZHER2K", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ - if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && *beta == - 1.) { - return 0; + if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && *beta == + 1.) { + return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0. && alpha->i == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ - i__4].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L30: */ - } - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = *beta * c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; /* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L50: */ - } + } /* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = *beta * c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ - i__4].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L70: */ - } + } /* L80: */ - } - } - } - return 0; + } + } + } + return 0; } /* Start the operations. */ @@ -382,361 +382,361 @@ extern "C" { /* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + */ /* C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L90: */ - } - } else if (*beta != 1.) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ - i__4].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else if (*beta != 1.) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L100: */ - } - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = *beta * c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; - } else { - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - i__3 = j + l * a_dim1; - i__4 = j + l * b_dim1; - if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != - 0. || b[i__4].i != 0.)) { - d_cnjg(&z__2, &b[j + l * b_dim1]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, - z__1.i = alpha->r * z__2.i + alpha->i * - z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__3 = j + l * a_dim1; - z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, - z__2.i = alpha->r * a[i__3].i + alpha->i * a[ - i__3].r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - i__3 = j - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * c_dim1; - i__6 = i__ + l * a_dim1; - z__3.r = a[i__6].r * temp1.r - a[i__6].i * - temp1.i, z__3.i = a[i__6].r * temp1.i + a[ - i__6].i * temp1.r; - z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] - .i + z__3.i; - i__7 = i__ + l * b_dim1; - z__4.r = b[i__7].r * temp2.r - b[i__7].i * - temp2.i, z__4.i = b[i__7].r * temp2.i + b[ - i__7].i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + - z__4.i; - c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, + z__1.i = alpha->r * z__2.i + alpha->i * + z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L110: */ - } - i__3 = j + j * c_dim1; - i__4 = j + j * c_dim1; - i__5 = j + l * a_dim1; - z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, - z__2.i = a[i__5].r * temp1.i + a[i__5].i * - temp1.r; - i__6 = j + l * b_dim1; - z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, - z__3.i = b[i__6].r * temp2.i + b[i__6].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = c__[i__4].r + z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } /* L120: */ - } + } /* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; /* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ - i__4].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L150: */ - } - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = *beta * c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; - } else { - i__2 = j + j * c_dim1; - i__3 = j + j * c_dim1; - d__1 = c__[i__3].r; - c__[i__2].r = d__1, c__[i__2].i = 0.; - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - i__3 = j + l * a_dim1; - i__4 = j + l * b_dim1; - if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != - 0. || b[i__4].i != 0.)) { - d_cnjg(&z__2, &b[j + l * b_dim1]); - z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, - z__1.i = alpha->r * z__2.i + alpha->i * - z__2.r; - temp1.r = z__1.r, temp1.i = z__1.i; - i__3 = j + l * a_dim1; - z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, - z__2.i = alpha->r * a[i__3].i + alpha->i * a[ - i__3].r; - d_cnjg(&z__1, &z__2); - temp2.r = z__1.r, temp2.i = z__1.i; - i__3 = *n; - for (i__ = j + 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * c_dim1; - i__6 = i__ + l * a_dim1; - z__3.r = a[i__6].r * temp1.r - a[i__6].i * - temp1.i, z__3.i = a[i__6].r * temp1.i + a[ - i__6].i * temp1.r; - z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] - .i + z__3.i; - i__7 = i__ + l * b_dim1; - z__4.r = b[i__7].r * temp2.r - b[i__7].i * - temp2.i, z__4.i = b[i__7].r * temp2.i + b[ - i__7].i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + - z__4.i; - c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, + z__1.i = alpha->r * z__2.i + alpha->i * + z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L160: */ - } - i__3 = j + j * c_dim1; - i__4 = j + j * c_dim1; - i__5 = j + l * a_dim1; - z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, - z__2.i = a[i__5].r * temp1.i + a[i__5].i * - temp1.r; - i__6 = j + l * b_dim1; - z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, - z__3.i = b[i__6].r * temp2.i + b[i__6].i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - d__1 = c__[i__4].r + z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } /* L170: */ - } + } /* L180: */ - } - } + } + } } else { /* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + */ /* C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1.r = 0., temp1.i = 0.; - temp2.r = 0., temp2.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - d_cnjg(&z__3, &a[l + i__ * a_dim1]); - i__4 = l + j * b_dim1; - z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, - z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] - .r; - z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; - temp1.r = z__1.r, temp1.i = z__1.i; - d_cnjg(&z__3, &b[l + i__ * b_dim1]); - i__4 = l + j * a_dim1; - z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, - z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] - .r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_cnjg(&z__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; /* L190: */ - } - if (i__ == j) { - if (*beta == 0.) { - i__3 = j + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - d__1 = z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } else { - i__3 = j + j * c_dim1; - i__4 = j + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - d__1 = *beta * c__[i__4].r + z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } - } else { - if (*beta == 0.) { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__3.r = *beta * c__[i__4].r, z__3.i = *beta * - c__[i__4].i; - z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__4.i = alpha->r * temp1.i + alpha->i * - temp1.r; - z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + - z__4.i; - d_cnjg(&z__6, alpha); - z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, - z__5.i = z__6.r * temp2.i + z__6.i * - temp2.r; - z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + - z__5.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } - } + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * + c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + + z__4.i; + d_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } /* L200: */ - } + } /* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1.r = 0., temp1.i = 0.; - temp2.r = 0., temp2.i = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - d_cnjg(&z__3, &a[l + i__ * a_dim1]); - i__4 = l + j * b_dim1; - z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, - z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] - .r; - z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; - temp1.r = z__1.r, temp1.i = z__1.i; - d_cnjg(&z__3, &b[l + i__ * b_dim1]); - i__4 = l + j * a_dim1; - z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, - z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] - .r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_cnjg(&z__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; /* L220: */ - } - if (i__ == j) { - if (*beta == 0.) { - i__3 = j + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - d__1 = z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } else { - i__3 = j + j * c_dim1; - i__4 = j + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - d__1 = *beta * c__[i__4].r + z__1.r; - c__[i__3].r = d__1, c__[i__3].i = 0.; - } - } else { - if (*beta == 0.) { - i__3 = i__ + j * c_dim1; - z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__2.i = alpha->r * temp1.i + alpha->i * - temp1.r; - d_cnjg(&z__4, alpha); - z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, - z__3.i = z__4.r * temp2.i + z__4.i * - temp2.r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } else { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - z__3.r = *beta * c__[i__4].r, z__3.i = *beta * - c__[i__4].i; - z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, - z__4.i = alpha->r * temp1.i + alpha->i * - temp1.r; - z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + - z__4.i; - d_cnjg(&z__6, alpha); - z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, - z__5.i = z__6.r * temp2.i + z__6.i * - temp2.r; - z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + - z__5.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; - } - } + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * + c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + + z__4.i; + d_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } /* L230: */ - } + } /* L240: */ - } - } + } + } } return 0; @@ -746,5 +746,5 @@ extern "C" { } /* zher2k_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zhetd2.cpp b/lib/linalg/zhetd2.cpp index c6c59ad6d5..71ad2aeab4 100644 --- a/lib/linalg/zhetd2.cpp +++ b/lib/linalg/zhetd2.cpp @@ -1,13 +1,13 @@ /* fortran/zhetd2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -197,9 +197,9 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zhetd2_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, - integer *info, ftnlen uplo_len) +/* Subroutine */ int zhetd2_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, + integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -209,21 +209,21 @@ f"> */ /* Local variables */ integer i__; doublecomplex taui; - extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen); doublecomplex alpha; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); - extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, doublecomplex *, integer *, ftnlen); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen); logical upper; - extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( - char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *); + extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( + char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); /* -- LAPACK computational routine -- */ @@ -263,169 +263,169 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZHETD2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZHETD2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } if (upper) { /* Reduce the upper triangle of A */ - i__1 = *n + *n * a_dim1; - i__2 = *n + *n * a_dim1; - d__1 = a[i__2].r; - a[i__1].r = d__1, a[i__1].i = 0.; - for (i__ = *n - 1; i__ >= 1; --i__) { + i__1 = *n + *n * a_dim1; + i__2 = *n + *n * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + for (i__ = *n - 1; i__ >= 1; --i__) { /* Generate elementary reflector H(i) = I - tau * v * v**H */ /* to annihilate A(1:i-1,i+1) */ - i__1 = i__ + (i__ + 1) * a_dim1; - alpha.r = a[i__1].r, alpha.i = a[i__1].i; - zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui); - e[i__] = alpha.r; + i__1 = i__ + (i__ + 1) * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui); + e[i__] = alpha.r; - if (taui.r != 0. || taui.i != 0.) { + if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(1:i,1:i) */ - i__1 = i__ + (i__ + 1) * a_dim1; - a[i__1].r = 1., a[i__1].i = 0.; + i__1 = i__ + (i__ + 1) * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; /* Compute x := tau * A * v storing x in TAU(1:i) */ - zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * - a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1, (ftnlen)1); + zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * + a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1, (ftnlen)1); /* Compute w := x - 1/2 * tau * (x**H * v) * v */ - z__3.r = -.5, z__3.i = -0.; - z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * - taui.i + z__3.i * taui.r; - zdotc_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] - , &c__1); - z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * - z__4.i + z__2.i * z__4.r; - alpha.r = z__1.r, alpha.i = z__1.i; - zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ - 1], &c__1); + z__3.r = -.5, z__3.i = -0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * + taui.i + z__3.i * taui.r; + zdotc_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] + , &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ + 1], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**H - w * v**H */ - z__1.r = -1., z__1.i = -0.; - zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & - tau[1], &c__1, &a[a_offset], lda, (ftnlen)1); + z__1.r = -1., z__1.i = -0.; + zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & + tau[1], &c__1, &a[a_offset], lda, (ftnlen)1); - } else { - i__1 = i__ + i__ * a_dim1; - i__2 = i__ + i__ * a_dim1; - d__1 = a[i__2].r; - a[i__1].r = d__1, a[i__1].i = 0.; - } - i__1 = i__ + (i__ + 1) * a_dim1; - i__2 = i__; - a[i__1].r = e[i__2], a[i__1].i = 0.; - i__1 = i__ + 1 + (i__ + 1) * a_dim1; - d__[i__ + 1] = a[i__1].r; - i__1 = i__; - tau[i__1].r = taui.r, tau[i__1].i = taui.i; + } else { + i__1 = i__ + i__ * a_dim1; + i__2 = i__ + i__ * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } + i__1 = i__ + (i__ + 1) * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2], a[i__1].i = 0.; + i__1 = i__ + 1 + (i__ + 1) * a_dim1; + d__[i__ + 1] = a[i__1].r; + i__1 = i__; + tau[i__1].r = taui.r, tau[i__1].i = taui.i; /* L10: */ - } - i__1 = a_dim1 + 1; - d__[1] = a[i__1].r; + } + i__1 = a_dim1 + 1; + d__[1] = a[i__1].r; } else { /* Reduce the lower triangle of A */ - i__1 = a_dim1 + 1; - i__2 = a_dim1 + 1; - d__1 = a[i__2].r; - a[i__1].r = d__1, a[i__1].i = 0.; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) = I - tau * v * v**H */ /* to annihilate A(i+2:n,i) */ - i__2 = i__ + 1 + i__ * a_dim1; - alpha.r = a[i__2].r, alpha.i = a[i__2].i; - i__2 = *n - i__; + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, & - taui); - e[i__] = alpha.r; + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, & + taui); + e[i__] = alpha.r; - if (taui.r != 0. || taui.i != 0.) { + if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - i__2 = i__ + 1 + i__ * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; /* Compute x := tau * A * v storing y in TAU(i:n-1) */ - i__2 = *n - i__; - zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ - i__], &c__1, (ftnlen)1); + i__2 = *n - i__; + zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ + i__], &c__1, (ftnlen)1); /* Compute w := x - 1/2 * tau * (x**H * v) * v */ - z__3.r = -.5, z__3.i = -0.; - z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * - taui.i + z__3.i * taui.r; - i__2 = *n - i__; - zdotc_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * - a_dim1], &c__1); - z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * - z__4.i + z__2.i * z__4.r; - alpha.r = z__1.r, alpha.i = z__1.i; - i__2 = *n - i__; - zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &c__1); + z__3.r = -.5, z__3.i = -0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * + taui.i + z__3.i * taui.r; + i__2 = *n - i__; + zdotc_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * + a_dim1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - i__; + zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**H - w * v**H */ - i__2 = *n - i__; - z__1.r = -1., z__1.i = -0.; - zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1, - &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, (ftnlen)1); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1, + &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, (ftnlen)1); - } else { - i__2 = i__ + 1 + (i__ + 1) * a_dim1; - i__3 = i__ + 1 + (i__ + 1) * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } - i__2 = i__ + 1 + i__ * a_dim1; - i__3 = i__; - a[i__2].r = e[i__3], a[i__2].i = 0.; - i__2 = i__ + i__ * a_dim1; - d__[i__] = a[i__2].r; - i__2 = i__; - tau[i__2].r = taui.r, tau[i__2].i = taui.i; + } else { + i__2 = i__ + 1 + (i__ + 1) * a_dim1; + i__3 = i__ + 1 + (i__ + 1) * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + i__2 = i__ + 1 + i__ * a_dim1; + i__3 = i__; + a[i__2].r = e[i__3], a[i__2].i = 0.; + i__2 = i__ + i__ * a_dim1; + d__[i__] = a[i__2].r; + i__2 = i__; + tau[i__2].r = taui.r, tau[i__2].i = taui.i; /* L20: */ - } - i__1 = *n + *n * a_dim1; - d__[*n] = a[i__1].r; + } + i__1 = *n + *n * a_dim1; + d__[*n] = a[i__1].r; } return 0; @@ -435,5 +435,5 @@ f"> */ } /* zhetd2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zhetrd.cpp b/lib/linalg/zhetrd.cpp index e1c8481bbb..ed3de347ef 100644 --- a/lib/linalg/zhetrd.cpp +++ b/lib/linalg/zhetrd.cpp @@ -1,13 +1,13 @@ /* fortran/zhetrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -216,9 +216,9 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, - doublecomplex *work, integer *lwork, integer *info, ftnlen uplo_len) +/* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, + doublecomplex *work, integer *lwork, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -229,17 +229,17 @@ f"> */ extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; logical upper; - extern /* Subroutine */ int zhetd2_(char *, integer *, doublecomplex *, - integer *, doublereal *, doublereal *, doublecomplex *, integer *, - ftnlen), zher2k_(char *, char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublereal *, doublecomplex *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int zlatrd_(char *, integer *, integer *, - doublecomplex *, integer *, doublereal *, doublecomplex *, - doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int zhetd2_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *, + ftnlen), zher2k_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublereal *, doublecomplex *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlatrd_(char *, integer *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *, + doublecomplex *, integer *, ftnlen); integer ldwork, lwkopt; logical lquery; @@ -283,38 +283,38 @@ f"> */ upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); lquery = *lwork == -1; if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else if (*lwork < 1 && ! lquery) { - *info = -9; + *info = -9; } if (*info == 0) { /* Determine the block size. */ - nb = ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); - lwkopt = *n * nb; - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + nb = ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZHETRD", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZHETRD", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - work[1].r = 1., work[1].i = 0.; - return 0; + work[1].r = 1., work[1].i = 0.; + return 0; } nx = *n; @@ -325,35 +325,35 @@ f"> */ /* (last block is always handled by unblocked code). */ /* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *n) { + i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *n) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: determine the */ /* minimum value of NB, and reduce NB or force use of */ /* unblocked code by setting NX = N. */ /* Computing MAX */ - i__1 = *lwork / ldwork; - nb = max(i__1,1); - nbmin = ilaenv_(&c__2, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, - (ftnlen)6, (ftnlen)1); - if (nb < nbmin) { - nx = *n; - } - } - } else { - nx = *n; - } + i__1 = *lwork / ldwork; + nb = max(i__1,1); + nbmin = ilaenv_(&c__2, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } } else { - nb = 1; + nb = 1; } if (upper) { @@ -361,94 +361,94 @@ f"> */ /* Reduce the upper triangle of A. */ /* Columns 1:kk are handled by the unblocked method. */ - kk = *n - (*n - nx + nb - 1) / nb * nb; - i__1 = kk + 1; - i__2 = -nb; - for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ - i__3 = i__ + nb - 1; - zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & - work[1], &ldwork, (ftnlen)1); + i__3 = i__ + nb - 1; + zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & + work[1], &ldwork, (ftnlen)1); /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ /* update of the form: A := A - V*W**H - W*V**H */ - i__3 = i__ - 1; - z__1.r = -1., z__1.i = -0.; - zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1 - + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda, ( - ftnlen)1, (ftnlen)12); + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1 + + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda, ( + ftnlen)1, (ftnlen)12); /* Copy superdiagonal elements back into A, and diagonal */ /* elements into D */ - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - i__4 = j - 1 + j * a_dim1; - i__5 = j - 1; - a[i__4].r = e[i__5], a[i__4].i = 0.; - i__4 = j + j * a_dim1; - d__[j] = a[i__4].r; + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j - 1 + j * a_dim1; + i__5 = j - 1; + a[i__4].r = e[i__5], a[i__4].i = 0.; + i__4 = j + j * a_dim1; + d__[j] = a[i__4].r; /* L10: */ - } + } /* L20: */ - } + } /* Use unblocked code to reduce the last or only block */ - zhetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, - (ftnlen)1); + zhetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, + (ftnlen)1); } else { /* Reduce the lower triangle of A */ - i__2 = *n - nx; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ - i__3 = *n - i__ + 1; - zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & - tau[i__], &work[1], &ldwork, (ftnlen)1); + i__3 = *n - i__ + 1; + zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & + tau[i__], &work[1], &ldwork, (ftnlen)1); /* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */ /* an update of the form: A := A - V*W**H - W*V**H */ - i__3 = *n - i__ - nb + 1; - z__1.r = -1., z__1.i = -0.; - zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ + nb + - i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ - i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)1, (ftnlen) - 12); + i__3 = *n - i__ - nb + 1; + z__1.r = -1., z__1.i = -0.; + zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ + nb + + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ + i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)1, (ftnlen) + 12); /* Copy subdiagonal elements back into A, and diagonal */ /* elements into D */ - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - i__4 = j + 1 + j * a_dim1; - i__5 = j; - a[i__4].r = e[i__5], a[i__4].i = 0.; - i__4 = j + j * a_dim1; - d__[j] = a[i__4].r; + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j + 1 + j * a_dim1; + i__5 = j; + a[i__4].r = e[i__5], a[i__4].i = 0.; + i__4 = j + j * a_dim1; + d__[j] = a[i__4].r; /* L30: */ - } + } /* L40: */ - } + } /* Use unblocked code to reduce the last or only block */ - i__1 = *n - i__ + 1; - zhetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], - &tau[i__], &iinfo, (ftnlen)1); + i__1 = *n - i__ + 1; + zhetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], + &tau[i__], &iinfo, (ftnlen)1); } work[1].r = (doublereal) lwkopt, work[1].i = 0.; @@ -459,5 +459,5 @@ f"> */ } /* zhetrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zhpr.cpp b/lib/linalg/zhpr.cpp index f3c36d5826..b977b2ce1e 100644 --- a/lib/linalg/zhpr.cpp +++ b/lib/linalg/zhpr.cpp @@ -1,13 +1,13 @@ /* fortran/zhpr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -143,8 +143,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha, - doublecomplex *x, integer *incx, doublecomplex *ap, ftnlen uplo_len) +/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha, + doublecomplex *x, integer *incx, doublecomplex *ap, ftnlen uplo_len) { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; @@ -192,30 +192,30 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; + ftnlen)1, (ftnlen)1)) { + info = 1; } else if (*n < 0) { - info = 2; + info = 2; } else if (*incx == 0) { - info = 5; + info = 5; } if (info != 0) { - xerbla_((char *)"ZHPR ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZHPR ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0 || *alpha == 0.) { - return 0; + return 0; } /* Set the start point in X if the increment is not unity. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of the array AP */ @@ -226,172 +226,172 @@ extern "C" { /* Form A when upper triangle is stored in AP. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - d_cnjg(&z__2, &x[j]); - z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = k; - i__4 = k; - i__5 = i__; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, - z__2.i = x[i__5].r * temp.i + x[i__5].i * - temp.r; - z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + - z__2.i; - ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; - ++k; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; /* L10: */ - } - i__2 = kk + j - 1; - i__3 = kk + j - 1; - i__4 = j; - z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = - x[i__4].r * temp.i + x[i__4].i * temp.r; - d__1 = ap[i__3].r + z__1.r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } else { - i__2 = kk + j - 1; - i__3 = kk + j - 1; - d__1 = ap[i__3].r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } - kk += j; + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk += j; /* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - d_cnjg(&z__2, &x[jx]); - z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - i__3 = k; - i__4 = k; - i__5 = ix; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, - z__2.i = x[i__5].r * temp.i + x[i__5].i * - temp.r; - z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + - z__2.i; - ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ix += *incx; /* L30: */ - } - i__2 = kk + j - 1; - i__3 = kk + j - 1; - i__4 = jx; - z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = - x[i__4].r * temp.i + x[i__4].i * temp.r; - d__1 = ap[i__3].r + z__1.r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } else { - i__2 = kk + j - 1; - i__3 = kk + j - 1; - d__1 = ap[i__3].r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } - jx += *incx; - kk += j; + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk += j; /* L40: */ - } - } + } + } } else { /* Form A when lower triangle is stored in AP. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - d_cnjg(&z__2, &x[j]); - z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = kk; - i__3 = kk; - i__4 = j; - z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = - temp.r * x[i__4].i + temp.i * x[i__4].r; - d__1 = ap[i__3].r + z__1.r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = k; - i__4 = k; - i__5 = i__; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, - z__2.i = x[i__5].r * temp.i + x[i__5].i * - temp.r; - z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + - z__2.i; - ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; - ++k; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; /* L50: */ - } - } else { - i__2 = kk; - i__3 = kk; - d__1 = ap[i__3].r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } - kk = kk + *n - j + 1; + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk = kk + *n - j + 1; /* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - d_cnjg(&z__2, &x[jx]); - z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = kk; - i__3 = kk; - i__4 = jx; - z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = - temp.r * x[i__4].i + temp.i * x[i__4].r; - d__1 = ap[i__3].r + z__1.r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - ix = jx; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - i__3 = k; - i__4 = k; - i__5 = ix; - z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, - z__2.i = x[i__5].r * temp.i + x[i__5].i * - temp.r; - z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + - z__2.i; - ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = k; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; /* L70: */ - } - } else { - i__2 = kk; - i__3 = kk; - d__1 = ap[i__3].r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - } - jx += *incx; - kk = kk + *n - j + 1; + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk = kk + *n - j + 1; /* L80: */ - } - } + } + } } return 0; @@ -401,5 +401,5 @@ extern "C" { } /* zhpr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlacgv.cpp b/lib/linalg/zlacgv.cpp index 46c1c5c0ce..9e9a4050b2 100644 --- a/lib/linalg/zlacgv.cpp +++ b/lib/linalg/zlacgv.cpp @@ -1,13 +1,13 @@ /* fortran/zlacgv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -125,26 +125,26 @@ f"> */ /* Function Body */ if (*incx == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - d_cnjg(&z__1, &x[i__]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_cnjg(&z__1, &x[i__]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* L10: */ - } + } } else { - ioff = 1; - if (*incx < 0) { - ioff = 1 - (*n - 1) * *incx; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = ioff; - d_cnjg(&z__1, &x[ioff]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - ioff += *incx; + ioff = 1; + if (*incx < 0) { + ioff = 1 - (*n - 1) * *incx; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ioff; + d_cnjg(&z__1, &x[ioff]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ioff += *incx; /* L20: */ - } + } } return 0; @@ -153,5 +153,5 @@ f"> */ } /* zlacgv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlacpy.cpp b/lib/linalg/zlacpy.cpp index 1cb52d4c0a..4a68cd9e07 100644 --- a/lib/linalg/zlacpy.cpp +++ b/lib/linalg/zlacpy.cpp @@ -1,13 +1,13 @@ /* fortran/zlacpy.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -119,9 +119,9 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - ftnlen uplo_len) +/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; @@ -160,43 +160,43 @@ f"> */ /* Function Body */ if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * a_dim1; - b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L10: */ - } + } /* L20: */ - } + } } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * a_dim1; - b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L30: */ - } + } /* L40: */ - } + } } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * a_dim1; - b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L50: */ - } + } /* L60: */ - } + } } return 0; @@ -206,5 +206,5 @@ f"> */ } /* zlacpy_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlacrm.cpp b/lib/linalg/zlacrm.cpp index e993f79aa5..46508ae4a9 100644 --- a/lib/linalg/zlacrm.cpp +++ b/lib/linalg/zlacrm.cpp @@ -1,13 +1,13 @@ /* fortran/zlacrm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -135,13 +135,13 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *b, integer *ldb, doublecomplex *c__, - integer *ldc, doublereal *rwork) +/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *b, integer *ldb, doublecomplex *c__, + integer *ldc, doublereal *rwork) { /* System generated locals */ - integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; + integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; doublereal d__1; doublecomplex z__1; @@ -150,9 +150,9 @@ f"> */ /* Local variables */ integer i__, j, l; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); /* -- LAPACK auxiliary routine -- */ @@ -192,58 +192,58 @@ f"> */ /* Function Body */ if (*m == 0 || *n == 0) { - return 0; + return 0; } i__1 = *n; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - rwork[(j - 1) * *m + i__] = a[i__3].r; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + rwork[(j - 1) * *m + i__] = a[i__3].r; /* L10: */ - } + } /* L20: */ } l = *m * *n + 1; dgemm_((char *)"N", (char *)"N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & - rwork[l], m, (ftnlen)1, (ftnlen)1); + rwork[l], m, (ftnlen)1, (ftnlen)1); i__1 = *n; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = l + (j - 1) * *m + i__ - 1; - c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = l + (j - 1) * *m + i__ - 1; + c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; /* L30: */ - } + } /* L40: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - rwork[(j - 1) * *m + i__] = d_imag(&a[i__ + j * a_dim1]); + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + rwork[(j - 1) * *m + i__] = d_imag(&a[i__ + j * a_dim1]); /* L50: */ - } + } /* L60: */ } dgemm_((char *)"N", (char *)"N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & - rwork[l], m, (ftnlen)1, (ftnlen)1); + rwork[l], m, (ftnlen)1, (ftnlen)1); i__1 = *n; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - d__1 = c__[i__4].r; - i__5 = l + (j - 1) * *m + i__ - 1; - z__1.r = d__1, z__1.i = rwork[i__5]; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + d__1 = c__[i__4].r; + i__5 = l + (j - 1) * *m + i__ - 1; + z__1.r = d__1, z__1.i = rwork[i__5]; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L70: */ - } + } /* L80: */ } @@ -254,5 +254,5 @@ f"> */ } /* zlacrm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zladiv.cpp b/lib/linalg/zladiv.cpp index 6e80b3371a..6b065d5ce0 100644 --- a/lib/linalg/zladiv.cpp +++ b/lib/linalg/zladiv.cpp @@ -1,13 +1,13 @@ /* fortran/zladiv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -80,8 +80,8 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x, - doublecomplex *y) +/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x, + doublecomplex *y) { /* System generated locals */ doublereal d__1, d__2, d__3, d__4; @@ -92,8 +92,8 @@ f"> */ /* Local variables */ doublereal zi, zr; - extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -128,5 +128,5 @@ f"> */ } /* zladiv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlaed0.cpp b/lib/linalg/zlaed0.cpp index 680dd85054..98bc39611d 100644 --- a/lib/linalg/zlaed0.cpp +++ b/lib/linalg/zlaed0.cpp @@ -1,13 +1,13 @@ /* fortran/zlaed0.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -22,7 +22,7 @@ static integer c__0 = 0; static integer c__2 = 2; static integer c__1 = 1; -/* > \brief \b ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced +/* > \brief \b ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. */ /* =========== DOCUMENTATION =========== */ @@ -168,9 +168,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore, - integer *ldqs, doublereal *rwork, integer *iwork, integer *info) +/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__, + doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore, + integer *ldqs, doublereal *rwork, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; @@ -184,27 +184,27 @@ f"> */ integer i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2; doublereal temp; integer curr, iperm; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); integer indxq, iwrem, iqptr, tlvls; - extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zlaed7_(integer *, integer *, - integer *, integer *, integer *, integer *, doublereal *, - doublecomplex *, integer *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *, integer *, integer *, - doublereal *, doublecomplex *, doublereal *, integer *, integer *) - ; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaed7_(integer *, integer *, + integer *, integer *, integer *, integer *, doublereal *, + doublecomplex *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, doublecomplex *, doublereal *, integer *, integer *) + ; integer igivcl; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int zlacrm_(integer *, integer *, doublecomplex *, - integer *, doublereal *, integer *, doublecomplex *, integer *, - doublereal *); + integer *, doublereal *, integer *, doublecomplex *, integer *, + doublereal *); integer igivnm, submat, curprb, subpbs, igivpt; - extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - ftnlen); + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + ftnlen); integer curlvl, matsiz, iprmpt, smlsiz; @@ -255,28 +255,28 @@ f"> */ /* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) */ /* $ THEN */ if (*qsiz < max(0,*n)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldq < max(1,*n)) { - *info = -6; + *info = -6; } else if (*ldqs < max(1,*n)) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZLAED0", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZLAED0", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } smlsiz = ilaenv_(&c__9, (char *)"ZLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( - ftnlen)6, (ftnlen)1); + ftnlen)6, (ftnlen)1); /* Determine the size and placement of the submatrices, and save in */ /* the leading elements of IWORK. */ @@ -286,18 +286,18 @@ f"> */ tlvls = 0; L10: if (iwork[subpbs] > smlsiz) { - for (j = subpbs; j >= 1; --j) { - iwork[j * 2] = (iwork[j] + 1) / 2; - iwork[(j << 1) - 1] = iwork[j] / 2; + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; /* L20: */ - } - ++tlvls; - subpbs <<= 1; - goto L10; + } + ++tlvls; + subpbs <<= 1; + goto L10; } i__1 = subpbs; for (j = 2; j <= i__1; ++j) { - iwork[j] += iwork[j - 1]; + iwork[j] += iwork[j - 1]; /* L30: */ } @@ -307,10 +307,10 @@ L10: spm1 = subpbs - 1; i__1 = spm1; for (i__ = 1; i__ <= i__1; ++i__) { - submat = iwork[i__] + 1; - smm1 = submat - 1; - d__[smm1] -= (d__1 = e[smm1], abs(d__1)); - d__[submat] -= (d__1 = e[smm1], abs(d__1)); + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); /* L40: */ } @@ -322,10 +322,10 @@ L10: temp = log((doublereal) (*n)) / log(2.); lgn = (integer) temp; if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; + ++lgn; } if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; + ++lgn; } iprmpt = indxq + *n + 1; iperm = iprmpt + *n * lgn; @@ -341,8 +341,8 @@ L10: /* Initialize pointers */ i__1 = subpbs; for (i__ = 0; i__ <= i__1; ++i__) { - iwork[iprmpt + i__] = 1; - iwork[igivpt + i__] = 1; + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; /* L50: */ } iwork[iqptr] = 1; @@ -353,34 +353,34 @@ L10: curr = 0; i__1 = spm1; for (i__ = 0; i__ <= i__1; ++i__) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[1]; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 1] - iwork[i__]; - } - ll = iq - 1 + iwork[iqptr + curr]; - dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, & - rwork[1], info, (ftnlen)1); - zlacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], & - matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem] - ); + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + ll = iq - 1 + iwork[iqptr + curr]; + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, & + rwork[1], info, (ftnlen)1); + zlacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], & + matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem] + ); /* Computing 2nd power */ - i__2 = matsiz; - iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; - ++curr; - if (*info > 0) { - *info = submat * (*n + 1) + submat + matsiz - 1; - return 0; - } - k = 1; - i__2 = iwork[i__ + 1]; - for (j = submat; j <= i__2; ++j) { - iwork[indxq + j] = k; - ++k; + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; /* L60: */ - } + } /* L70: */ } @@ -392,20 +392,20 @@ L10: curlvl = 1; L80: if (subpbs > 1) { - spm2 = subpbs - 2; - i__1 = spm2; - for (i__ = 0; i__ <= i__1; i__ += 2) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[2]; - msd2 = iwork[1]; - curprb = 0; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 2] - iwork[i__]; - msd2 = matsiz / 2; - ++curprb; - } + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } /* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ /* into an eigensystem of size MATSIZ. ZLAED7 handles the case */ @@ -414,22 +414,22 @@ L80: /* I am free to use Q as a valuable working space until Loop 150. */ - zlaed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[ - submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[ - submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], & - iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[ - igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat * - q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info); - if (*info > 0) { - *info = submat * (*n + 1) + submat + matsiz - 1; - return 0; - } - iwork[i__ / 2 + 1] = iwork[i__ + 2]; + zlaed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[ + submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[ + submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], & + iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[ + igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat * + q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info); + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; /* L90: */ - } - subpbs /= 2; - ++curlvl; - goto L80; + } + subpbs /= 2; + ++curlvl; + goto L80; } /* end while */ @@ -439,10 +439,10 @@ L80: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - rwork[i__] = d__[j]; - zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1] - , &c__1); + j = iwork[indxq + i__]; + rwork[i__] = d__[j]; + zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1] + , &c__1); /* L100: */ } dcopy_(n, &rwork[1], &c__1, &d__[1], &c__1); @@ -454,5 +454,5 @@ L80: } /* zlaed0_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlaed7.cpp b/lib/linalg/zlaed7.cpp index 9c06a0c334..b20d805e62 100644 --- a/lib/linalg/zlaed7.cpp +++ b/lib/linalg/zlaed7.cpp @@ -1,13 +1,13 @@ /* fortran/zlaed7.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -269,12 +269,12 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, - doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, - doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, - integer *givptr, integer *givcol, doublereal *givnum, doublecomplex * - work, doublereal *rwork, integer *iwork, integer *info) +/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, + doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, + doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, + integer *givptr, integer *givcol, doublereal *givnum, doublecomplex * + work, doublereal *rwork, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; @@ -284,23 +284,23 @@ f"> */ /* Local variables */ integer i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp; - extern /* Subroutine */ int dlaed9_(integer *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, integer *), - zlaed8_(integer *, integer *, integer *, doublecomplex *, integer - *, doublereal *, doublereal *, integer *, doublereal *, - doublereal *, doublecomplex *, integer *, doublereal *, integer *, - integer *, integer *, integer *, integer *, integer *, - doublereal *, integer *), dlaeda_(integer *, integer *, integer *, - integer *, integer *, integer *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *); + extern /* Subroutine */ int dlaed9_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *), + zlaed8_(integer *, integer *, integer *, doublecomplex *, integer + *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, integer *), dlaeda_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); integer idlmda; - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen), zlacrm_(integer *, integer *, doublecomplex *, integer *, - doublereal *, integer *, doublecomplex *, integer *, doublereal * - ); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen), zlacrm_(integer *, integer *, doublecomplex *, integer *, + doublereal *, integer *, doublecomplex *, integer *, doublereal * + ); integer coltyp; @@ -349,24 +349,24 @@ f"> */ /* INFO = -1 */ /* ELSE IF( N.LT.0 ) THEN */ if (*n < 0) { - *info = -1; + *info = -1; } else if (min(1,*n) > *cutpnt || *n < *cutpnt) { - *info = -2; + *info = -2; } else if (*qsiz < *n) { - *info = -3; + *info = -3; } else if (*ldq < max(1,*n)) { - *info = -9; + *info = -9; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZLAED7", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZLAED7", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* The following values are for bookkeeping purposes only. They are */ @@ -389,60 +389,60 @@ f"> */ ptr = pow_ii(&c__2, tlvls) + 1; i__1 = *curlvl - 1; for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *tlvls - i__; - ptr += pow_ii(&c__2, &i__2); + i__2 = *tlvls - i__; + ptr += pow_ii(&c__2, &i__2); /* L10: */ } curr = ptr + *curpbm; dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & - givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[ - iz + *n], info); + givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[ + iz + *n], info); /* When solving the final problem, we no longer need the stored data, */ /* so we will overwrite the data from this level onto the previously */ /* used storage space. */ if (*curlvl == *tlvls) { - qptr[curr] = 1; - prmptr[curr] = 1; - givptr[curr] = 1; + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; } /* Sort and Deflate eigenvalues. */ - zlaed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz], - &rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[ - indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[ - (givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info); + zlaed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz], + &rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[ + indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[ + (givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info); prmptr[curr + 1] = prmptr[curr] + *n; givptr[curr + 1] += givptr[curr]; /* Solve Secular Equation. */ if (k != 0) { - dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda] - , &rwork[iw], &qstore[qptr[curr]], &k, info); - zlacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[ - q_offset], ldq, &rwork[iq]); + dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda] + , &rwork[iw], &qstore[qptr[curr]], &k, info); + zlacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[ + q_offset], ldq, &rwork[iq]); /* Computing 2nd power */ - i__1 = k; - qptr[curr + 1] = qptr[curr] + i__1 * i__1; - if (*info != 0) { - return 0; - } + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + if (*info != 0) { + return 0; + } /* Prepare the INDXQ sorting premutation. */ - n1 = k; - n2 = *n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); } else { - qptr[curr + 1] = qptr[curr]; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indxq[i__] = i__; + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; /* L20: */ - } + } } return 0; @@ -452,5 +452,5 @@ f"> */ } /* zlaed7_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlaed8.cpp b/lib/linalg/zlaed8.cpp index 00f4db857b..77c07f385e 100644 --- a/lib/linalg/zlaed8.cpp +++ b/lib/linalg/zlaed8.cpp @@ -1,13 +1,13 @@ /* fortran/zlaed8.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -248,12 +248,12 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz, - doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho, - integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex * - q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, - integer *indxq, integer *perm, integer *givptr, integer *givcol, - doublereal *givnum, integer *info) +/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz, + doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho, + integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex * + q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, + integer *indxq, integer *perm, integer *givptr, integer *givcol, + doublereal *givnum, integer *info) { /* System generated locals */ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; @@ -269,19 +269,19 @@ f"> */ integer k2, n1, n2, jp, n1p1; doublereal eps, tau, tol; integer jlam, imax, jmax; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dcopy_(integer *, doublereal *, integer *, doublereal - *, integer *), zdrot_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublereal *, doublereal *), zcopy_( - integer *, doublecomplex *, integer *, doublecomplex *, integer *) - ; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *), zdrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *), zcopy_( + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + ; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer *, - ftnlen), zlacpy_(char *, integer *, integer *, doublecomplex *, - integer *, doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, + ftnlen), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen); /* -- LAPACK computational routine -- */ @@ -331,20 +331,20 @@ f"> */ *info = 0; if (*n < 0) { - *info = -2; + *info = -2; } else if (*qsiz < *n) { - *info = -3; + *info = -3; } else if (*ldq < max(1,*n)) { - *info = -5; + *info = -5; } else if (*cutpnt < min(1,*n) || *cutpnt > *n) { - *info = -8; + *info = -8; } else if (*ldq2 < max(1,*n)) { - *info = -12; + *info = -12; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZLAED8", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZLAED8", &i__1, (ftnlen)6); + return 0; } /* Need to initialize GIVPTR to O here in case of quick exit */ @@ -357,7 +357,7 @@ f"> */ /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } n1 = *cutpnt; @@ -365,7 +365,7 @@ f"> */ n1p1 = n1 + 1; if (*rho < 0.) { - dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); } /* Normalize z so that norm(z) = 1 */ @@ -373,7 +373,7 @@ f"> */ t = 1. / sqrt(2.); i__1 = *n; for (j = 1; j <= i__1; ++j) { - indx[j] = j; + indx[j] = j; /* L10: */ } dscal_(n, &t, &z__[1], &c__1); @@ -383,13 +383,13 @@ f"> */ i__1 = *n; for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { - indxq[i__] += *cutpnt; + indxq[i__] += *cutpnt; /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = d__[indxq[i__]]; - w[i__] = z__[indxq[i__]]; + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; /* L30: */ } i__ = 1; @@ -397,8 +397,8 @@ f"> */ dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = dlamda[indx[i__]]; - z__[i__] = w[indx[i__]]; + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; /* L40: */ } @@ -414,17 +414,17 @@ f"> */ /* elements in D. */ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { - *k = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - perm[j] = indxq[indx[j]]; - zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] - , &c__1); + *k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] + , &c__1); /* L50: */ - } - zlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, ( - ftnlen)1); - return 0; + } + zlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, ( + ftnlen)1); + return 0; } /* If there are multiple eigenvalues then the problem deflates. Here */ @@ -437,88 +437,88 @@ f"> */ k2 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { - if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - indxp[k2] = j; - if (j == *n) { - goto L100; - } - } else { - jlam = j; - goto L70; - } + --k2; + indxp[k2] = j; + if (j == *n) { + goto L100; + } + } else { + jlam = j; + goto L70; + } /* L60: */ } L70: ++j; if (j > *n) { - goto L90; + goto L90; } if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ - --k2; - indxp[k2] = j; + --k2; + indxp[k2] = j; } else { /* Check if eigenvalues are close enough to allow deflation. */ - s = z__[jlam]; - c__ = z__[j]; + s = z__[jlam]; + c__ = z__[j]; /* Find sqrt(a**2+b**2) without overflow or */ /* destructive underflow. */ - tau = dlapy2_(&c__, &s); - t = d__[j] - d__[jlam]; - c__ /= tau; - s = -s / tau; - if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { /* Deflation is possible. */ - z__[j] = tau; - z__[jlam] = 0.; + z__[j] = tau; + z__[jlam] = 0.; /* Record the appropriate Givens rotation */ - ++(*givptr); - givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; - givcol[(*givptr << 1) + 2] = indxq[indx[j]]; - givnum[(*givptr << 1) + 1] = c__; - givnum[(*givptr << 1) + 2] = s; - zdrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[ - indx[j]] * q_dim1 + 1], &c__1, &c__, &s); - t = d__[jlam] * c__ * c__ + d__[j] * s * s; - d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; - d__[jlam] = t; - --k2; - i__ = 1; + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + zdrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[ + indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; L80: - if (k2 + i__ <= *n) { - if (d__[jlam] < d__[indxp[k2 + i__]]) { - indxp[k2 + i__ - 1] = indxp[k2 + i__]; - indxp[k2 + i__] = jlam; - ++i__; - goto L80; - } else { - indxp[k2 + i__ - 1] = jlam; - } - } else { - indxp[k2 + i__ - 1] = jlam; - } - jlam = j; - } else { - ++(*k); - w[*k] = z__[jlam]; - dlamda[*k] = d__[jlam]; - indxp[*k] = jlam; - jlam = j; - } + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L80; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } } goto L70; L90: @@ -539,11 +539,11 @@ L100: i__1 = *n; for (j = 1; j <= i__1; ++j) { - jp = indxp[j]; - dlamda[j] = d__[jp]; - perm[j] = indxq[indx[jp]]; - zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], & - c__1); + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], & + c__1); /* L110: */ } @@ -551,11 +551,11 @@ L100: /* into the last N - K slots of D and Q respectively. */ if (*k < *n) { - i__1 = *n - *k; - dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = *n - *k; - zlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + - 1) * q_dim1 + 1], ldq, (ftnlen)1); + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + zlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + + 1) * q_dim1 + 1], ldq, (ftnlen)1); } return 0; @@ -565,5 +565,5 @@ L100: } /* zlaed8_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlanhe.cpp b/lib/linalg/zlanhe.cpp index 2522e8d500..c54482158a 100644 --- a/lib/linalg/zlanhe.cpp +++ b/lib/linalg/zlanhe.cpp @@ -1,13 +1,13 @@ /* fortran/zlanhe.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -145,8 +145,8 @@ f"> */ /* > \ingroup complex16HEauxiliary */ /* ===================================================================== */ -doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len) +doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *work, ftnlen norm_len, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; @@ -162,7 +162,7 @@ doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, doublereal value; extern logical disnan_(doublereal *); extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, - doublereal *, doublereal *); + doublereal *, doublereal *); /* -- LAPACK auxiliary routine -- */ @@ -196,144 +196,144 @@ doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, /* Function Body */ if (*n == 0) { - value = 0.; + value = 0.; } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ - value = 0.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - sum = z_abs(&a[i__ + j * a_dim1]); - if (value < sum || disnan_(&sum)) { - value = sum; - } + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L10: */ - } - i__2 = j + j * a_dim1; - sum = (d__1 = a[i__2].r, abs(d__1)); - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j + j * a_dim1; - sum = (d__1 = a[i__2].r, abs(d__1)); - if (value < sum || disnan_(&sum)) { - value = sum; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - sum = z_abs(&a[i__ + j * a_dim1]); - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L30: */ - } + } /* L40: */ - } - } + } + } } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", ( - ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { + ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is hermitian). */ - value = 0.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - absa = z_abs(&a[i__ + j * a_dim1]); - sum += absa; - work[i__] += absa; + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; /* L50: */ - } - i__2 = j + j * a_dim1; - work[j] = sum + (d__1 = a[i__2].r, abs(d__1)); + } + i__2 = j + j * a_dim1; + work[j] = sum + (d__1 = a[i__2].r, abs(d__1)); /* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - sum = work[i__]; - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; /* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j + j * a_dim1; - sum = work[j] + (d__1 = a[i__2].r, abs(d__1)); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - absa = z_abs(&a[i__ + j * a_dim1]); - sum += absa; - work[i__] += absa; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = work[j] + (d__1 = a[i__2].r, abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; /* L90: */ - } - if (value < sum || disnan_(&sum)) { - value = sum; - } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } /* L100: */ - } - } + } + } } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", ( - ftnlen)1, (ftnlen)1)) { + ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ - scale = 0.; - sum = 1.; - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + scale = 0.; + sum = 1.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L110: */ - } - } else { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); /* L120: */ - } - } - sum *= 2; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - if (a[i__2].r != 0.) { - i__2 = i__ + i__ * a_dim1; - absa = (d__1 = a[i__2].r, abs(d__1)); - if (scale < absa) { + } + } + sum *= 2; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (a[i__2].r != 0.) { + i__2 = i__ + i__ * a_dim1; + absa = (d__1 = a[i__2].r, abs(d__1)); + if (scale < absa) { /* Computing 2nd power */ - d__1 = scale / absa; - sum = sum * (d__1 * d__1) + 1.; - scale = absa; - } else { + d__1 = scale / absa; + sum = sum * (d__1 * d__1) + 1.; + scale = absa; + } else { /* Computing 2nd power */ - d__1 = absa / scale; - sum += d__1 * d__1; - } - } + d__1 = absa / scale; + sum += d__1 * d__1; + } + } /* L130: */ - } - value = scale * sqrt(sum); + } + value = scale * sqrt(sum); } ret_val = value; @@ -344,5 +344,5 @@ doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, } /* zlanhe_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlarf.cpp b/lib/linalg/zlarf.cpp index 453644e7d9..7bee520eae 100644 --- a/lib/linalg/zlarf.cpp +++ b/lib/linalg/zlarf.cpp @@ -1,13 +1,13 @@ /* fortran/zlarf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -150,9 +150,9 @@ static integer c__1 = 1; /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex - *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer * - ldc, doublecomplex *work, ftnlen side_len) +/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex + *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer * + ldc, doublecomplex *work, ftnlen side_len) { /* System generated locals */ integer c_dim1, c_offset, i__1; @@ -163,14 +163,14 @@ static integer c__1 = 1; logical applyleft; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer lastc; - extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); integer lastv; - extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *), - ilazlr_(integer *, integer *, doublecomplex *, integer *); + extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *), + ilazlr_(integer *, integer *, doublecomplex *, integer *); /* -- LAPACK auxiliary routine -- */ @@ -208,31 +208,31 @@ static integer c__1 = 1; if (tau->r != 0. || tau->i != 0.) { /* Set up variables for scanning V. LASTV begins pointing to the end */ /* of V. */ - if (applyleft) { - lastv = *m; - } else { - lastv = *n; - } - if (*incv > 0) { - i__ = (lastv - 1) * *incv + 1; - } else { - i__ = 1; - } + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } /* Look for the last non-zero row in V. */ - for(;;) { /* while(complicated condition) */ - i__1 = i__; - if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.))) - break; - --lastv; - i__ -= *incv; - } - if (applyleft) { + for(;;) { /* while(complicated condition) */ + i__1 = i__; + if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.))) + break; + --lastv; + i__ -= *incv; + } + if (applyleft) { /* Scan for the last non-zero column in C(1:lastv,:). */ - lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); - } else { + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + } else { /* Scan for the last non-zero row in C(:,1:lastv). */ - lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); - } + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + } } /* Note that lastc.eq.0 renders the BLAS operations null; no special */ /* case is needed at this level. */ @@ -240,37 +240,37 @@ static integer c__1 = 1; /* Form H * C */ - if (lastv > 0) { + if (lastv > 0) { /* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) */ - zgemv_((char *)"Conjugate transpose", &lastv, &lastc, &c_b1, &c__[ - c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1, ( - ftnlen)19); + zgemv_((char *)"Conjugate transpose", &lastv, &lastc, &c_b1, &c__[ + c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1, ( + ftnlen)19); /* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H */ - z__1.r = -tau->r, z__1.i = -tau->i; - zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[ - c_offset], ldc); - } + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[ + c_offset], ldc); + } } else { /* Form C * H */ - if (lastv > 0) { + if (lastv > 0) { /* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ - zgemv_((char *)"No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc, - &v[1], incv, &c_b2, &work[1], &c__1, (ftnlen)12); + zgemv_((char *)"No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc, + &v[1], incv, &c_b2, &work[1], &c__1, (ftnlen)12); /* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H */ - z__1.r = -tau->r, z__1.i = -tau->i; - zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[ - c_offset], ldc); - } + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[ + c_offset], ldc); + } } return 0; @@ -279,5 +279,5 @@ static integer c__1 = 1; } /* zlarf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlarfb.cpp b/lib/linalg/zlarfb.cpp index 0ea0c17bd4..b09fdf4917 100644 --- a/lib/linalg/zlarfb.cpp +++ b/lib/linalg/zlarfb.cpp @@ -1,13 +1,13 @@ /* fortran/zlarfb.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -218,14 +218,14 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, doublecomplex *v, integer - *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer * - ldc, doublecomplex *work, integer *ldwork, ftnlen side_len, ftnlen - trans_len, ftnlen direct_len, ftnlen storev_len) + storev, integer *m, integer *n, integer *k, doublecomplex *v, integer + *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer * + ldc, doublecomplex *work, integer *ldwork, ftnlen side_len, ftnlen + trans_len, ftnlen direct_len, ftnlen storev_len) { /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2, i__3, i__4, i__5; + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1, z__2; /* Builtin functions */ @@ -234,15 +234,15 @@ f"> */ /* Local variables */ integer i__, j; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, - integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen), zcopy_(integer *, doublecomplex *, - integer *, doublecomplex *, integer *), ztrmm_(char *, char *, - char *, char *, integer *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, - ftnlen, ftnlen, ftnlen), zlacgv_(integer *, doublecomplex *, - integer *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen), zcopy_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrmm_(char *, char *, + char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, + ftnlen, ftnlen, ftnlen), zlacgv_(integer *, doublecomplex *, + integer *); char transt[1]; @@ -287,24 +287,24 @@ f"> */ /* Function Body */ if (*m <= 0 || *n <= 0) { - return 0; + return 0; } if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { - *(unsigned char *)transt = 'C'; + *(unsigned char *)transt = 'C'; } else { - *(unsigned char *)transt = 'N'; + *(unsigned char *)transt = 'N'; } if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { /* Let V = ( V1 ) (first K rows) */ /* ( V2 ) */ /* where V1 is unit lower triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**H * C where C = ( C1 ) */ /* ( C2 ) */ @@ -313,74 +313,74 @@ f"> */ /* W := C1**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], - &c__1); - zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L10: */ - } + } /* W := W * V1 */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*m > *k) { + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { /* W := W + C2**H * V2 */ - i__1 = *m - *k; - zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, - &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + - v_dim1], ldv, &c_b1, &work[work_offset], ldwork, ( - ftnlen)19, (ftnlen)12); - } + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, + &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + + v_dim1], ldv, &c_b1, &work[work_offset], ldwork, ( + ftnlen)19, (ftnlen)12); + } /* W := W * T**H or W * T */ - ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V * W**H */ - if (*m > *k) { + if (*m > *k) { /* C2 := C2 - V2 * W**H */ - i__1 = *m - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, - &z__1, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] - , ldc, (ftnlen)12, (ftnlen)19); - } + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, + &z__1, &v[*k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] + , ldc, (ftnlen)12, (ftnlen)19); + } /* W := W * V1**H */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, - &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, - (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, + (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); /* C1 := C1 - W**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L20: */ - } + } /* L30: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**H where C = ( C1 C2 ) */ @@ -388,80 +388,80 @@ f"> */ /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); /* L40: */ - } + } /* W := W * V1 */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*n > *k) { + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { /* W := W + C2 * V2 */ - i__1 = *n - *k; - zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, - &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + - v_dim1], ldv, &c_b1, &work[work_offset], ldwork, ( - ftnlen)12, (ftnlen)12); - } + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + + v_dim1], ldv, &c_b1, &work[work_offset], ldwork, ( + ftnlen)12, (ftnlen)12); + } /* W := W * T or W * T**H */ - ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V**H */ - if (*n > *k) { + if (*n > *k) { /* C2 := C2 - W * V2**H */ - i__1 = *n - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, - &z__1, &work[work_offset], ldwork, &v[*k + 1 + - v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], - ldc, (ftnlen)12, (ftnlen)19); - } + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, + &z__1, &work[work_offset], ldwork, &v[*k + 1 + + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], + ldc, (ftnlen)12, (ftnlen)19); + } /* W := W * V1**H */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, - &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, - (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, + (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L50: */ - } + } /* L60: */ - } - } + } + } - } else { + } else { /* Let V = ( V1 ) */ /* ( V2 ) (last K rows) */ /* where V2 is unit upper triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**H * C where C = ( C1 ) */ /* ( C2 ) */ @@ -470,75 +470,75 @@ f"> */ /* W := C2**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * - work_dim1 + 1], &c__1); - zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L70: */ - } + } /* W := W * V2 */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, - &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*m > *k) { + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { /* W := W + C1**H * V1 */ - i__1 = *m - *k; - zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, - &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b1, &work[work_offset], ldwork, (ftnlen)19, ( - ftnlen)12); - } + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, + &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b1, &work[work_offset], ldwork, (ftnlen)19, ( + ftnlen)12); + } /* W := W * T**H or W * T */ - ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V * W**H */ - if (*m > *k) { + if (*m > *k) { /* C1 := C1 - V1 * W**H */ - i__1 = *m - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, - &z__1, &v[v_offset], ldv, &work[work_offset], - ldwork, &c_b1, &c__[c_offset], ldc, (ftnlen)12, ( - ftnlen)19); - } + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, + &z__1, &v[v_offset], ldv, &work[work_offset], + ldwork, &c_b1, &c__[c_offset], ldc, (ftnlen)12, ( + ftnlen)19); + } /* W := W * V2**H */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, - &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 19, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, + &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 19, (ftnlen)4); /* C2 := C2 - W**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = *m - *k + j + i__ * c_dim1; - i__4 = *m - *k + j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L80: */ - } + } /* L90: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**H where C = ( C1 C2 ) */ @@ -546,83 +546,83 @@ f"> */ /* W := C2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ - j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); /* L100: */ - } + } /* W := W * V2 */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, - &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], - ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); - if (*n > *k) { + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { /* W := W + C1 * V1 */ - i__1 = *n - *k; - zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, - &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, & - work[work_offset], ldwork, (ftnlen)12, (ftnlen)12) - ; - } + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, & + work[work_offset], ldwork, (ftnlen)12, (ftnlen)12) + ; + } /* W := W * T or W * T**H */ - ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V**H */ - if (*n > *k) { + if (*n > *k) { /* C1 := C1 - W * V1**H */ - i__1 = *n - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, - &z__1, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b1, &c__[c_offset], ldc, (ftnlen)12, ( - ftnlen)19); - } + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, + &z__1, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b1, &c__[c_offset], ldc, (ftnlen)12, ( + ftnlen)19); + } /* W := W * V2**H */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, - &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 19, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, + &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 19, (ftnlen)4); /* C2 := C2 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (*n - *k + j) * c_dim1; - i__4 = i__ + (*n - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L110: */ - } + } /* L120: */ - } - } - } + } + } + } } else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { /* Let V = ( V1 V2 ) (V1: first K columns) */ /* where V1 is unit upper triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**H * C where C = ( C1 ) */ /* ( C2 ) */ @@ -631,74 +631,74 @@ f"> */ /* W := C1**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], - &c__1); - zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L130: */ - } + } /* W := W * V1**H */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, - &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, - (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); - if (*m > *k) { + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, + (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); + if (*m > *k) { /* W := W + C2**H * V2**H */ - i__1 = *m - *k; - zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, - &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[(*k - + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] - , ldwork, (ftnlen)19, (ftnlen)19); - } + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, + &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[(*k + + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] + , ldwork, (ftnlen)19, (ftnlen)19); + } /* W := W * T**H or W * T */ - ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V**H * W**H */ - if (*m > *k) { + if (*m > *k) { /* C2 := C2 - V2**H * W**H */ - i__1 = *m - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", & - i__1, n, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv, - &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + - c_dim1], ldc, (ftnlen)19, (ftnlen)19); - } + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", & + i__1, n, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + + c_dim1], ldc, (ftnlen)19, (ftnlen)19); + } /* W := W * V1 */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); /* C1 := C1 - W**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L140: */ - } + } /* L150: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**H where C = ( C1 C2 ) */ @@ -706,80 +706,80 @@ f"> */ /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); /* L160: */ - } + } /* W := W * V1**H */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, - &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, - (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); - if (*n > *k) { + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, + (ftnlen)5, (ftnlen)5, (ftnlen)19, (ftnlen)4); + if (*n > *k) { /* W := W + C2 * V2**H */ - i__1 = *n - *k; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, - &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k - + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] - , ldwork, (ftnlen)12, (ftnlen)19); - } + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, + &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] + , ldwork, (ftnlen)12, (ftnlen)19); + } /* W := W * T or W * T**H */ - ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V */ - if (*n > *k) { + if (*n > *k) { /* C2 := C2 - W * V2 */ - i__1 = *n - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, - &work[work_offset], ldwork, &v[(*k + 1) * v_dim1 - + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], - ldc, (ftnlen)12, (ftnlen)12); - } + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[(*k + 1) * v_dim1 + + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], + ldc, (ftnlen)12, (ftnlen)12); + } /* W := W * V1 */ - ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, - &v[v_offset], ldv, &work[work_offset], ldwork, ( - ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork, ( + ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L170: */ - } + } /* L180: */ - } + } - } + } - } else { + } else { /* Let V = ( V1 V2 ) (V2: last K columns) */ /* where V2 is unit lower triangular. */ - if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form H * C or H**H * C where C = ( C1 ) */ /* ( C2 ) */ @@ -788,76 +788,76 @@ f"> */ /* W := C2**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * - work_dim1 + 1], &c__1); - zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L190: */ - } + } /* W := W * V2**H */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, - &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 19, (ftnlen)4); - if (*m > *k) { + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, + &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 19, (ftnlen)4); + if (*m > *k) { /* W := W + C1**H * V1**H */ - i__1 = *m - *k; - zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, - &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], - ldv, &c_b1, &work[work_offset], ldwork, (ftnlen) - 19, (ftnlen)19); - } + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, + &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], + ldv, &c_b1, &work[work_offset], ldwork, (ftnlen) + 19, (ftnlen)19); + } /* W := W * T**H or W * T */ - ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - V**H * W**H */ - if (*m > *k) { + if (*m > *k) { /* C1 := C1 - V1**H * W**H */ - i__1 = *m - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", & - i__1, n, k, &z__1, &v[v_offset], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[c_offset], ldc, - (ftnlen)19, (ftnlen)19); - } + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", & + i__1, n, k, &z__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &c__[c_offset], ldc, + (ftnlen)19, (ftnlen)19); + } /* W := W * V2 */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, - &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 12, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 12, (ftnlen)4); /* C2 := C2 - W**H */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = *m - *k + j + i__ * c_dim1; - i__4 = *m - *k + j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L200: */ - } + } /* L210: */ - } + } - } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form C * H or C * H**H where C = ( C1 C2 ) */ @@ -865,77 +865,77 @@ f"> */ /* W := C2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ - j * work_dim1 + 1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); /* L220: */ - } + } /* W := W * V2**H */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, - &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 19, (ftnlen)4); - if (*n > *k) { + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, + &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 19, (ftnlen)4); + if (*n > *k) { /* W := W + C1 * V1**H */ - i__1 = *n - *k; - zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, - &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b1, &work[work_offset], ldwork, (ftnlen)12, ( - ftnlen)19); - } + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, + &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b1, &work[work_offset], ldwork, (ftnlen)12, ( + ftnlen)19); + } /* W := W * T or W * T**H */ - ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[ - t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, - (ftnlen)5, (ftnlen)1, (ftnlen)8); + ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)1, (ftnlen)8); /* C := C - W * V */ - if (*n > *k) { + if (*n > *k) { /* C1 := C1 - W * V1 */ - i__1 = *n - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, - &work[work_offset], ldwork, &v[v_offset], ldv, & - c_b1, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)12) - ; - } + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[v_offset], ldv, & + c_b1, &c__[c_offset], ldc, (ftnlen)12, (ftnlen)12) + ; + } /* W := W * V2 */ - ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, - &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) - 12, (ftnlen)4); + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen) + 12, (ftnlen)4); /* C1 := C1 - W */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (*n - *k + j) * c_dim1; - i__4 = i__ + (*n - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L230: */ - } + } /* L240: */ - } + } - } + } - } + } } return 0; @@ -945,5 +945,5 @@ f"> */ } /* zlarfb_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlarfg.cpp b/lib/linalg/zlarfg.cpp index e3d58be892..71e2add68c 100644 --- a/lib/linalg/zlarfg.cpp +++ b/lib/linalg/zlarfg.cpp @@ -1,13 +1,13 @@ /* fortran/zlarfg.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -127,7 +127,7 @@ f"> */ /* ===================================================================== */ /* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex * - x, integer *incx, doublecomplex *tau) + x, integer *incx, doublecomplex *tau) { /* System generated locals */ integer i__1; @@ -140,18 +140,18 @@ f"> */ /* Local variables */ integer j, knt; doublereal beta, alphi, alphr; - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); doublereal xnorm; - extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), - dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *, - ftnlen); + extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), + dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *, + ftnlen); doublereal safmin; - extern /* Subroutine */ int zdscal_(integer *, doublereal *, - doublecomplex *, integer *); + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); doublereal rsafmn; extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, - doublecomplex *); + doublecomplex *); /* -- LAPACK auxiliary routine -- */ @@ -182,8 +182,8 @@ f"> */ /* Function Body */ if (*n <= 0) { - tau->r = 0., tau->i = 0.; - return 0; + tau->r = 0., tau->i = 0.; + return 0; } i__1 = *n - 1; @@ -195,59 +195,59 @@ f"> */ /* H = I */ - tau->r = 0., tau->i = 0.; + tau->r = 0., tau->i = 0.; } else { /* general case */ - d__1 = dlapy3_(&alphr, &alphi, &xnorm); - beta = -d_sign(&d__1, &alphr); - safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); - rsafmn = 1. / safmin; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); + safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); + rsafmn = 1. / safmin; - knt = 0; - if (abs(beta) < safmin) { + knt = 0; + if (abs(beta) < safmin) { /* XNORM, BETA may be inaccurate; scale X and recompute them */ L10: - ++knt; - i__1 = *n - 1; - zdscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - alphi *= rsafmn; - alphr *= rsafmn; - if (abs(beta) < safmin && knt < 20) { - goto L10; - } + ++knt; + i__1 = *n - 1; + zdscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + alphi *= rsafmn; + alphr *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } /* New BETA is at most 1, at least SAFMIN */ - i__1 = *n - 1; - xnorm = dznrm2_(&i__1, &x[1], incx); - z__1.r = alphr, z__1.i = alphi; - alpha->r = z__1.r, alpha->i = z__1.i; - d__1 = dlapy3_(&alphr, &alphi, &xnorm); - beta = -d_sign(&d__1, &alphr); - } - d__1 = (beta - alphr) / beta; - d__2 = -alphi / beta; - z__1.r = d__1, z__1.i = d__2; - tau->r = z__1.r, tau->i = z__1.i; - z__2.r = alpha->r - beta, z__2.i = alpha->i; - zladiv_(&z__1, &c_b5, &z__2); - alpha->r = z__1.r, alpha->i = z__1.i; - i__1 = *n - 1; - zscal_(&i__1, alpha, &x[1], incx); + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + z__1.r = alphr, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); + } + d__1 = (beta - alphr) / beta; + d__2 = -alphi / beta; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + z__2.r = alpha->r - beta, z__2.i = alpha->i; + zladiv_(&z__1, &c_b5, &z__2); + alpha->r = z__1.r, alpha->i = z__1.i; + i__1 = *n - 1; + zscal_(&i__1, alpha, &x[1], incx); /* If ALPHA is subnormal, it may lose relative accuracy */ - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; /* L20: */ - } - alpha->r = beta, alpha->i = 0.; + } + alpha->r = beta, alpha->i = 0.; } return 0; @@ -257,5 +257,5 @@ L10: } /* zlarfg_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlarft.cpp b/lib/linalg/zlarft.cpp index d907f6792d..ad5e46b910 100644 --- a/lib/linalg/zlarft.cpp +++ b/lib/linalg/zlarft.cpp @@ -1,13 +1,13 @@ /* static/zlarft.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -185,8 +185,8 @@ f"> */ /* > */ /* ===================================================================== */ /* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer * - k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex * - t, integer *ldt, ftnlen direct_len, ftnlen storev_len) + k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex * + t, integer *ldt, ftnlen direct_len, ftnlen storev_len) { /* System generated locals */ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5; @@ -198,16 +198,16 @@ f"> */ /* Local variables */ integer i__, j, prevlastv; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, - integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen), zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); integer lastv; - extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, - ftnlen, ftnlen); + extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, + ftnlen, ftnlen); /* -- LAPACK auxiliary routine -- */ @@ -244,215 +244,215 @@ f"> */ /* Function Body */ if (*n == 0) { - return 0; + return 0; } if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(prevlastv,i__); - i__2 = i__; - if (tau[i__2].r == 0. && tau[i__2].i == 0.) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(prevlastv,i__); + i__2 = i__; + if (tau[i__2].r == 0. && tau[i__2].i == 0.) { /* H(i) = I */ - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - t[i__3].r = 0., t[i__3].i = 0.; - } - } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + } + } else { /* general case */ - if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { /* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = lastv + i__ * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - goto L220; - } - } + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = lastv + i__ * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + goto L220; + } + } L220: - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; - d_cnjg(&z__3, &v[i__ + j * v_dim1]); - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = - z__2.r * z__3.i + z__2.i * z__3.r; - t[i__3].r = z__1.r, t[i__3].i = z__1.i; - } - j = min(lastv,prevlastv); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + d_cnjg(&z__3, &v[i__ + j * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = min(lastv,prevlastv); /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) */ - i__2 = j - i__; - i__3 = i__ - 1; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ - + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], & - c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) - 19); - } else { + i__2 = j - i__; + i__3 = i__ - 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ + + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], & + c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) + 19); + } else { /* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = i__ + lastv * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - goto L236; - } - } + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = i__ + lastv * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + goto L236; + } + } L236: - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; - i__5 = j + i__ * v_dim1; - z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, - z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5] - .r; - t[i__3].r = z__1.r, t[i__3].i = z__1.i; - } - j = min(lastv,prevlastv); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + i__5 = j + i__ * v_dim1; + z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, + z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5] + .r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = min(lastv,prevlastv); /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H */ - i__2 = i__ - 1; - i__3 = j - i__; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemm_((char *)"N", (char *)"C", &i__2, &c__1, &i__3, &z__1, &v[(i__ + 1) - * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt, (ftnlen)1, - (ftnlen)1); - } + i__2 = i__ - 1; + i__3 = j - i__; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemm_((char *)"N", (char *)"C", &i__2, &c__1, &i__3, &z__1, &v[(i__ + 1) + * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], + ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt, (ftnlen)1, + (ftnlen)1); + } /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - i__2 = i__ - 1; - ztrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) - 5, (ftnlen)12, (ftnlen)8); - i__2 = i__ + i__ * t_dim1; - i__3 = i__; - t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - } + i__2 = i__ - 1; + ztrmv_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", &i__2, &t[ + t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen) + 5, (ftnlen)12, (ftnlen)8); + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + if (i__ > 1) { + prevlastv = max(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + } } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - i__1 = i__; - if (tau[i__1].r == 0. && tau[i__1].i == 0.) { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0. && tau[i__1].i == 0.) { /* H(i) = I */ - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - t[i__2].r = 0., t[i__2].i = 0.; - } - } else { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + } else { /* general case */ - if (i__ < *k) { - if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (i__ < *k) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { /* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = lastv + i__ * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - goto L281; - } - } + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = lastv + i__ * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + goto L281; + } + } L281: - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; - d_cnjg(&z__3, &v[*n - *k + i__ + j * v_dim1]); - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, - z__1.i = z__2.r * z__3.i + z__2.i * - z__3.r; - t[i__2].r = z__1.r, t[i__2].i = z__1.i; - } - j = max(lastv,prevlastv); + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + d_cnjg(&z__3, &v[*n - *k + i__ + j * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, + z__1.i = z__2.r * z__3.i + z__2.i * + z__3.r; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = max(lastv,prevlastv); /* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) */ - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemv_((char *)"Conjugate transpose", &i__1, &i__2, &z__1, &v[ - j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * - v_dim1], &c__1, &c_b1, &t[i__ + 1 + i__ * - t_dim1], &c__1, (ftnlen)19); - } else { + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_((char *)"Conjugate transpose", &i__1, &i__2, &z__1, &v[ + j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * + v_dim1], &c__1, &c_b1, &t[i__ + 1 + i__ * + t_dim1], &c__1, (ftnlen)19); + } else { /* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = i__ + lastv * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - goto L297; - } - } + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = i__ + lastv * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + goto L297; + } + } L297: - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; - i__4 = j + (*n - *k + i__) * v_dim1; - z__1.r = z__2.r * v[i__4].r - z__2.i * v[i__4].i, - z__1.i = z__2.r * v[i__4].i + z__2.i * v[ - i__4].r; - t[i__2].r = z__1.r, t[i__2].i = z__1.i; - } - j = max(lastv,prevlastv); + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + i__4 = j + (*n - *k + i__) * v_dim1; + z__1.r = z__2.r * v[i__4].r - z__2.i * v[i__4].i, + z__1.i = z__2.r * v[i__4].i + z__2.i * v[ + i__4].r; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = max(lastv,prevlastv); /* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H */ - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemm_((char *)"N", (char *)"C", &i__1, &c__1, &i__2, &z__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt, ( - ftnlen)1, (ftnlen)1); - } + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemm_((char *)"N", (char *)"C", &i__1, &c__1, &i__2, &z__1, &v[i__ + + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], + ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt, ( + ftnlen)1, (ftnlen)1); + } /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - i__1 = *k - i__; - ztrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - i__1 = i__ + i__ * t_dim1; - i__2 = i__; - t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; - } - } + i__1 = *k - i__; + ztrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, &t[i__ + + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8) + ; + if (i__ > 1) { + prevlastv = min(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } + } } return 0; @@ -461,5 +461,5 @@ L297: } /* zlarft_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlascl.cpp b/lib/linalg/zlascl.cpp index 337dd64793..8cea99ddb0 100644 --- a/lib/linalg/zlascl.cpp +++ b/lib/linalg/zlascl.cpp @@ -1,13 +1,13 @@ /* fortran/zlascl.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -159,9 +159,9 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublecomplex *a, integer *lda, integer *info, ftnlen type_len) +/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku, + doublereal *cfrom, doublereal *cto, integer *m, integer *n, + doublecomplex *a, integer *lda, integer *info, ftnlen type_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -216,63 +216,63 @@ f"> */ *info = 0; if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) { - itype = 0; + itype = 0; } else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) { - itype = 1; + itype = 1; } else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) { - itype = 2; + itype = 2; } else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) { - itype = 3; + itype = 3; } else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) { - itype = 4; + itype = 4; } else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) { - itype = 5; + itype = 5; } else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) { - itype = 6; + itype = 6; } else { - itype = -1; + itype = -1; } if (itype == -1) { - *info = -1; + *info = -1; } else if (*cfrom == 0. || disnan_(cfrom)) { - *info = -4; + *info = -4; } else if (disnan_(cto)) { - *info = -5; + *info = -5; } else if (*m < 0) { - *info = -6; + *info = -6; } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { - *info = -7; + *info = -7; } else if (itype <= 3 && *lda < max(1,*m)) { - *info = -9; + *info = -9; } else if (itype >= 4) { /* Computing MAX */ - i__1 = *m - 1; - if (*kl < 0 || *kl > max(i__1,0)) { - *info = -2; - } else /* if(complicated condition) */ { + i__1 = *m - 1; + if (*kl < 0 || *kl > max(i__1,0)) { + *info = -2; + } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = *n - 1; - if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && - *kl != *ku) { - *info = -3; - } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * - ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { - *info = -9; - } - } + i__1 = *n - 1; + if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZLASCL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZLASCL", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0 || *m == 0) { - return 0; + return 0; } /* Get machine parameters */ @@ -288,175 +288,175 @@ L10: if (cfrom1 == cfromc) { /* CFROMC is an inf. Multiply by a correctly signed zero for */ /* finite CTOC, or a NaN if CTOC is infinite. */ - mul = ctoc / cfromc; - done = TRUE_; - cto1 = ctoc; + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; } else { - cto1 = ctoc / bignum; - if (cto1 == ctoc) { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { /* CTOC is either 0 or an inf. In both cases, CTOC itself */ /* serves as the correct multiplication factor. */ - mul = ctoc; - done = TRUE_; - cfromc = 1.; - } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { - mul = smlnum; - done = FALSE_; - cfromc = cfrom1; - } else if (abs(cto1) > abs(cfromc)) { - mul = bignum; - done = FALSE_; - ctoc = cto1; - } else { - mul = ctoc / cfromc; - done = TRUE_; - if (mul == 1.) { - return 0; - } - } + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + if (mul == 1.) { + return 0; + } + } } if (itype == 0) { /* Full matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L20: */ - } + } /* L30: */ - } + } } else if (itype == 1) { /* Lower triangular matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L40: */ - } + } /* L50: */ - } + } } else if (itype == 2) { /* Upper triangular matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L60: */ - } + } /* L70: */ - } + } } else if (itype == 3) { /* Upper Hessenberg matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MIN */ - i__3 = j + 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L80: */ - } + } /* L90: */ - } + } } else if (itype == 4) { /* Lower half of a symmetric band matrix */ - k3 = *kl + 1; - k4 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MIN */ - i__3 = k3, i__4 = k4 - j; - i__2 = min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = k3, i__4 = k4 - j; + i__2 = min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L100: */ - } + } /* L110: */ - } + } } else if (itype == 5) { /* Upper half of a symmetric band matrix */ - k1 = *ku + 2; - k3 = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MAX */ - i__2 = k1 - j; - i__3 = k3; - for (i__ = max(i__2,1); i__ <= i__3; ++i__) { - i__2 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = k1 - j; + i__3 = k3; + for (i__ = max(i__2,1); i__ <= i__3; ++i__) { + i__2 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L120: */ - } + } /* L130: */ - } + } } else if (itype == 6) { /* Band matrix */ - k1 = *kl + *ku + 2; - k2 = *kl + 1; - k3 = (*kl << 1) + *ku + 1; - k4 = *kl + *ku + 1 + *m; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Computing MAX */ - i__3 = k1 - j; + i__3 = k1 - j; /* Computing MIN */ - i__4 = k3, i__5 = k4 - j; - i__2 = min(i__4,i__5); - for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + j * a_dim1; - z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__4 = k3, i__5 = k4 - j; + i__2 = min(i__4,i__5); + for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L140: */ - } + } /* L150: */ - } + } } if (! done) { - goto L10; + goto L10; } return 0; @@ -466,5 +466,5 @@ L10: } /* zlascl_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlaset.cpp b/lib/linalg/zlaset.cpp index e402ea02fe..782cc99055 100644 --- a/lib/linalg/zlaset.cpp +++ b/lib/linalg/zlaset.cpp @@ -1,13 +1,13 @@ /* fortran/zlaset.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -123,9 +123,9 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n, - doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer * - lda, ftnlen uplo_len) +/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer * + lda, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -165,68 +165,68 @@ f"> */ /* Set the diagonal to BETA and the strictly upper triangular */ /* part of the array to ALPHA. */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { /* Computing MIN */ - i__3 = j - 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - a[i__3].r = alpha->r, a[i__3].i = alpha->i; + i__3 = j - 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L10: */ - } + } /* L20: */ - } - i__1 = min(*n,*m); - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - a[i__2].r = beta->r, a[i__2].i = beta->i; + } + i__1 = min(*n,*m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; /* L30: */ - } + } } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Set the diagonal to BETA and the strictly lower triangular */ /* part of the array to ALPHA. */ - i__1 = min(*m,*n); - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - a[i__3].r = alpha->r, a[i__3].i = alpha->i; + i__1 = min(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L40: */ - } + } /* L50: */ - } - i__1 = min(*n,*m); - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - a[i__2].r = beta->r, a[i__2].i = beta->i; + } + i__1 = min(*n,*m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; /* L60: */ - } + } } else { /* Set the array to BETA on the diagonal and ALPHA on the */ /* offdiagonal. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - a[i__3].r = alpha->r, a[i__3].i = alpha->i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L70: */ - } + } /* L80: */ - } - i__1 = min(*m,*n); - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - a[i__2].r = beta->r, a[i__2].i = beta->i; + } + i__1 = min(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; /* L90: */ - } + } } return 0; @@ -236,5 +236,5 @@ f"> */ } /* zlaset_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlasr.cpp b/lib/linalg/zlasr.cpp index 23d68bf82f..51c9797679 100644 --- a/lib/linalg/zlasr.cpp +++ b/lib/linalg/zlasr.cpp @@ -1,13 +1,13 @@ /* fortran/zlasr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -217,8 +217,8 @@ extern "C" { /* ===================================================================== */ /* Subroutine */ int zlasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, doublereal *c__, doublereal *s, doublecomplex *a, - integer *lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len) + integer *n, doublereal *c__, doublereal *s, doublecomplex *a, + integer *lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; @@ -267,420 +267,420 @@ extern "C" { /* Function Body */ info = 0; if (! (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", ( - ftnlen)1, (ftnlen)1))) { - info = 1; - } else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot, - (char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, ( - ftnlen)1))) { - info = 2; - } else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct, - (char *)"B", (ftnlen)1, (ftnlen)1))) { - info = 3; + ftnlen)1, (ftnlen)1))) { + info = 1; + } else if (! (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || lsame_(pivot, + (char *)"T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, (char *)"B", (ftnlen)1, ( + ftnlen)1))) { + info = 2; + } else if (! (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(direct, + (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 3; } else if (*m < 0) { - info = 4; + info = 4; } else if (*n < 0) { - info = 5; + info = 5; } else if (*lda < max(1,*m)) { - info = 9; + info = 9; } if (info != 0) { - xerbla_((char *)"ZLASR ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZLASR ", &info, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { /* Form P * A */ - if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + 1 + i__ * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = j + 1 + i__ * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__4 = j + i__ * a_dim1; - z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ - i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = j + i__ * a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__4 = j + i__ * a_dim1; - z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ - i__4].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + 1 + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L10: */ - } - } + } + } /* L20: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = j + 1 + i__ * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = j + 1 + i__ * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__3 = j + i__ * a_dim1; - z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ - i__3].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = j + i__ * a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__3 = j + i__ * a_dim1; - z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ - i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + 1 + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L30: */ - } - } + } + } /* L40: */ - } - } - } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = j + i__ * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__4 = i__ * a_dim1 + 1; - z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ - i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = i__ * a_dim1 + 1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__4 = i__ * a_dim1 + 1; - z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ - i__4].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ - } - } + } + } /* L60: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = j + i__ * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = j + i__ * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__3 = i__ * a_dim1 + 1; - z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ - i__3].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = i__ * a_dim1 + 1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__3 = i__ * a_dim1 + 1; - z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ - i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L70: */ - } - } + } + } /* L80: */ - } - } - } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = j + i__ * a_dim1; - i__4 = *m + i__ * a_dim1; - z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ - i__4].i; - z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = *m + i__ * a_dim1; - i__4 = *m + i__ * a_dim1; - z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ - i__4].i; - z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ + i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = *m + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ + i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L90: */ - } - } + } + } /* L100: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = j + i__ * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = j + i__ * a_dim1; - i__3 = *m + i__ * a_dim1; - z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ - i__3].i; - z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = *m + i__ * a_dim1; - i__3 = *m + i__ * a_dim1; - z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ - i__3].i; - z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ + i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *m + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ + i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L110: */ - } - } + } + } /* L120: */ - } - } - } + } + } + } } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { /* Form A * P**T */ - if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (j + 1) * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = i__ + (j + 1) * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__4 = i__ + j * a_dim1; - z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ - i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = i__ + j * a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__4 = i__ + j * a_dim1; - z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ - i__4].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j + 1) * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L130: */ - } - } + } + } /* L140: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + (j + 1) * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = i__ + (j + 1) * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__3 = i__ + j * a_dim1; - z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ - i__3].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = i__ + j * a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__3 = i__ + j * a_dim1; - z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ - i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + (j + 1) * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L150: */ - } - } + } + } /* L160: */ - } - } - } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = i__ + j * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__4 = i__ + a_dim1; - z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ - i__4].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = i__ + a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__4 = i__ + a_dim1; - z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ - i__4].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L170: */ - } - } + } + } /* L180: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + j * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = i__ + j * a_dim1; - z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; - i__3 = i__ + a_dim1; - z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ - i__3].i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = i__ + a_dim1; - z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; - i__3 = i__ + a_dim1; - z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ - i__3].i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L190: */ - } - } + } + } /* L200: */ - } - } - } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { - if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - temp.r = a[i__3].r, temp.i = a[i__3].i; - i__3 = i__ + j * a_dim1; - i__4 = i__ + *n * a_dim1; - z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ - i__4].i; - z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - i__3 = i__ + *n * a_dim1; - i__4 = i__ + *n * a_dim1; - z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ - i__4].i; - z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ + i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + *n * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ + i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L210: */ - } - } + } + } /* L220: */ - } - } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + j * a_dim1; - temp.r = a[i__2].r, temp.i = a[i__2].i; - i__2 = i__ + j * a_dim1; - i__3 = i__ + *n * a_dim1; - z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ - i__3].i; - z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - i__2 = i__ + *n * a_dim1; - i__3 = i__ + *n * a_dim1; - z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ - i__3].i; - z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; - z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - - z__3.i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ + i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + *n * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ + i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L230: */ - } - } + } + } /* L240: */ - } - } - } + } + } + } } return 0; @@ -690,5 +690,5 @@ extern "C" { } /* zlasr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlassq.cpp b/lib/linalg/zlassq.cpp index 1fa44450fe..2e2a5ba539 100644 --- a/lib/linalg/zlassq.cpp +++ b/lib/linalg/zlassq.cpp @@ -1,13 +1,13 @@ /* fortran/zlassq.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -124,8 +124,8 @@ f"> */ /* > \ingroup complex16OTHERauxiliary */ /* ===================================================================== */ -/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx, - doublereal *scale, doublereal *sumsq) +/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx, + doublereal *scale, doublereal *sumsq) { /* System generated locals */ integer i__1, i__2, i__3; @@ -167,38 +167,38 @@ f"> */ /* Function Body */ if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - i__3 = ix; - temp1 = (d__1 = x[i__3].r, abs(d__1)); - if (temp1 > 0. || disnan_(&temp1)) { - if (*scale < temp1) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + temp1 = (d__1 = x[i__3].r, abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { /* Computing 2nd power */ - d__1 = *scale / temp1; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = temp1; - } else { + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { /* Computing 2nd power */ - d__1 = temp1 / *scale; - *sumsq += d__1 * d__1; - } - } - temp1 = (d__1 = d_imag(&x[ix]), abs(d__1)); - if (temp1 > 0. || disnan_(&temp1)) { - if (*scale < temp1) { + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } + temp1 = (d__1 = d_imag(&x[ix]), abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { /* Computing 2nd power */ - d__1 = *scale / temp1; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = temp1; - } else { + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { /* Computing 2nd power */ - d__1 = temp1 / *scale; - *sumsq += d__1 * d__1; - } - } + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } /* L10: */ - } + } } return 0; @@ -208,5 +208,5 @@ f"> */ } /* zlassq_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zlatrd.cpp b/lib/linalg/zlatrd.cpp index eaa0fc1826..d471ea96eb 100644 --- a/lib/linalg/zlatrd.cpp +++ b/lib/linalg/zlatrd.cpp @@ -1,13 +1,13 @@ /* fortran/zlatrd.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -222,9 +222,9 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb, - doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, - doublecomplex *w, integer *ldw, ftnlen uplo_len) +/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb, + doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, + doublecomplex *w, integer *ldw, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; @@ -235,20 +235,20 @@ f"> */ integer i__, iw; doublecomplex alpha; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *); - extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); - extern /* Subroutine */ int zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *, ftnlen), - zhemv_(char *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, ftnlen), zaxpy_(integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *, - integer *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, ftnlen), + zhemv_(char *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, ftnlen), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *, + integer *); /* -- LAPACK auxiliary routine -- */ @@ -288,214 +288,214 @@ f"> */ /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { /* Reduce last NB columns of upper triangle */ - i__1 = *n - *nb + 1; - for (i__ = *n; i__ >= i__1; --i__) { - iw = i__ - *n + *nb; - if (i__ < *n) { + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { /* Update A(1:i,i) */ - i__2 = i__ + i__ * a_dim1; - i__3 = i__ + i__ * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - i__2 = *n - i__; - zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); - i__2 = *n - i__; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & - c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); - i__2 = *n - i__; - zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); - i__2 = *n - i__; - zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); - i__2 = *n - i__; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); - i__2 = *n - i__; - zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); - i__2 = i__ + i__ * a_dim1; - i__3 = i__ + i__ * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - } - if (i__ > 1) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n - i__; + zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & + c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); + i__2 = *n - i__; + zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + if (i__ > 1) { /* Generate elementary reflector H(i) to annihilate */ /* A(1:i-2,i) */ - i__2 = i__ - 1 + i__ * a_dim1; - alpha.r = a[i__2].r, alpha.i = a[i__2].i; - i__2 = i__ - 1; - zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ - - 1]); - e[i__ - 1] = alpha.r; - i__2 = i__ - 1 + i__ * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; + i__2 = i__ - 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = i__ - 1; + zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ + - 1]); + e[i__ - 1] = alpha.r; + i__2 = i__ - 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; /* Compute W(1:i-1,i) */ - i__2 = i__ - 1; - zhemv_((char *)"Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * - a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1, - (ftnlen)5); - if (i__ < *n) { - i__2 = i__ - 1; - i__3 = *n - i__; - zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw - + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & - c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, ( - ftnlen)19); - i__2 = i__ - 1; - i__3 = *n - i__; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen) - 12); - i__2 = i__ - 1; - i__3 = *n - i__; - zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[( - i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], - &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, ( - ftnlen)19); - i__2 = i__ - 1; - i__3 = *n - i__; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) * - w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen) - 12); - } - i__2 = i__ - 1; - zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); - z__3.r = -.5, z__3.i = -0.; - i__2 = i__ - 1; - z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i = - z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; - i__3 = i__ - 1; - zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * - a_dim1 + 1], &c__1); - z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * - z__4.i + z__2.i * z__4.r; - alpha.r = z__1.r, alpha.i = z__1.i; - i__2 = i__ - 1; - zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * - w_dim1 + 1], &c__1); - } + i__2 = i__ - 1; + zhemv_((char *)"Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * + a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1, + (ftnlen)5); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & + c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, ( + ftnlen)19); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen) + 12); + i__2 = i__ - 1; + i__3 = *n - i__; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[( + i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], + &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, ( + ftnlen)19); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) * + w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen) + 12); + } + i__2 = i__ - 1; + zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + z__3.r = -.5, z__3.i = -0.; + i__2 = i__ - 1; + z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i = + z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; + i__3 = i__ - 1; + zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * + a_dim1 + 1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = i__ - 1; + zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * + w_dim1 + 1], &c__1); + } /* L10: */ - } + } } else { /* Reduce first NB columns of lower triangle */ - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i:n,i) */ - i__2 = i__ + i__ * a_dim1; - i__3 = i__ + i__ * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - i__2 = i__ - 1; - zlacgv_(&i__2, &w[i__ + w_dim1], ldw); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, - &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & - c__1, (ftnlen)12); - i__2 = i__ - 1; - zlacgv_(&i__2, &w[i__ + w_dim1], ldw); - i__2 = i__ - 1; - zlacgv_(&i__2, &a[i__ + a_dim1], lda); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw, - &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & - c__1, (ftnlen)12); - i__2 = i__ - 1; - zlacgv_(&i__2, &a[i__ + a_dim1], lda); - i__2 = i__ + i__ * a_dim1; - i__3 = i__ + i__ * a_dim1; - d__1 = a[i__3].r; - a[i__2].r = d__1, a[i__2].i = 0.; - if (i__ < *n) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = i__ - 1; + zlacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, + &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & + c__1, (ftnlen)12); + i__2 = i__ - 1; + zlacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw, + &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & + c__1, (ftnlen)12); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + if (i__ < *n) { /* Generate elementary reflector H(i) to annihilate */ /* A(i+2:n,i) */ - i__2 = i__ + 1 + i__ * a_dim1; - alpha.r = a[i__2].r, alpha.i = a[i__2].i; - i__2 = *n - i__; + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; /* Computing MIN */ - i__3 = i__ + 2; - zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, - &tau[i__]); - e[i__] = alpha.r; - i__2 = i__ + 1 + i__ * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, + &tau[i__]); + e[i__] = alpha.r; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; /* Compute W(i+1:n,i) */ - i__2 = *n - i__; - zhemv_((char *)"Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] - , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5); - i__2 = *n - i__; - i__3 = i__ - 1; - zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 - + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & - c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19); - i__2 = *n - i__; - i__3 = i__ - 1; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + - a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); - i__2 = *n - i__; - i__3 = i__ - 1; - zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 - + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & - c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19); - i__2 = *n - i__; - i__3 = i__ - 1; - z__1.r = -1., z__1.i = -0.; - zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 + - w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ - i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); - i__2 = *n - i__; - zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); - z__3.r = -.5, z__3.i = -0.; - i__2 = i__; - z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i = - z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; - i__3 = *n - i__; - zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ - i__ + 1 + i__ * a_dim1], &c__1); - z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * - z__4.i + z__2.i * z__4.r; - alpha.r = z__1.r, alpha.i = z__1.i; - i__2 = *n - i__; - zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - } + i__2 = *n - i__; + zhemv_((char *)"Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] + , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5); + i__2 = *n - i__; + i__3 = i__ - 1; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__; + i__3 = i__ - 1; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 + + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ + i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__; + zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + z__3.r = -.5, z__3.i = -0.; + i__2 = i__; + z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i = + z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; + i__3 = *n - i__; + zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - i__; + zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + } /* L20: */ - } + } } return 0; @@ -505,5 +505,5 @@ f"> */ } /* zlatrd_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zpptrf.cpp b/lib/linalg/zpptrf.cpp index ebf3b7df9a..d14e3678be 100644 --- a/lib/linalg/zpptrf.cpp +++ b/lib/linalg/zpptrf.cpp @@ -1,13 +1,13 @@ /* fortran/zpptrf.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -140,8 +140,8 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap, - integer *info, ftnlen uplo_len) +/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap, + integer *info, ftnlen uplo_len) { /* System generated locals */ integer i__1, i__2, i__3; @@ -154,16 +154,16 @@ f"> */ /* Local variables */ integer j, jc, jj; doublereal ajj; - extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, - doublecomplex *, integer *, doublecomplex *, ftnlen); + extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); logical upper; - extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *, - doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *, - doublereal *, doublecomplex *, integer *); + extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *, + doublereal *, doublecomplex *, integer *); /* -- LAPACK computational routine -- */ @@ -198,91 +198,91 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZPPTRF", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZPPTRF", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (upper) { /* Compute the Cholesky factorization A = U**H * U. */ - jj = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jc = jj + 1; - jj += j; + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; /* Compute elements 1:J-1 of column J. */ - if (j > 1) { - i__2 = j - 1; - ztpsv_((char *)"Upper", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[ - 1], &ap[jc], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)8); - } + if (j > 1) { + i__2 = j - 1; + ztpsv_((char *)"Upper", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[ + 1], &ap[jc], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)8); + } /* Compute U(J,J) and test for non-positive-definiteness. */ - i__2 = jj; - i__3 = j - 1; - zdotc_(&z__1, &i__3, &ap[jc], &c__1, &ap[jc], &c__1); - ajj = ap[i__2].r - z__1.r; - if (ajj <= 0.) { - i__2 = jj; - ap[i__2].r = ajj, ap[i__2].i = 0.; - goto L30; - } - i__2 = jj; - d__1 = sqrt(ajj); - ap[i__2].r = d__1, ap[i__2].i = 0.; + i__2 = jj; + i__3 = j - 1; + zdotc_(&z__1, &i__3, &ap[jc], &c__1, &ap[jc], &c__1); + ajj = ap[i__2].r - z__1.r; + if (ajj <= 0.) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; + goto L30; + } + i__2 = jj; + d__1 = sqrt(ajj); + ap[i__2].r = d__1, ap[i__2].i = 0.; /* L10: */ - } + } } else { /* Compute the Cholesky factorization A = L * L**H. */ - jj = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { /* Compute L(J,J) and test for non-positive-definiteness. */ - i__2 = jj; - ajj = ap[i__2].r; - if (ajj <= 0.) { - i__2 = jj; - ap[i__2].r = ajj, ap[i__2].i = 0.; - goto L30; - } - ajj = sqrt(ajj); - i__2 = jj; - ap[i__2].r = ajj, ap[i__2].i = 0.; + i__2 = jj; + ajj = ap[i__2].r; + if (ajj <= 0.) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; + goto L30; + } + ajj = sqrt(ajj); + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; /* Compute elements J+1:N of column J and update the trailing */ /* submatrix. */ - if (j < *n) { - i__2 = *n - j; - d__1 = 1. / ajj; - zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1); - i__2 = *n - j; - zhpr_((char *)"Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n - - j + 1], (ftnlen)5); - jj = jj + *n - j + 1; - } + if (j < *n) { + i__2 = *n - j; + d__1 = 1. / ajj; + zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1); + i__2 = *n - j; + zhpr_((char *)"Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n + - j + 1], (ftnlen)5); + jj = jj + *n - j + 1; + } /* L20: */ - } + } } goto L40; @@ -297,5 +297,5 @@ L40: } /* zpptrf_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zpptri.cpp b/lib/linalg/zpptri.cpp index fc11e435b1..e804683c79 100644 --- a/lib/linalg/zpptri.cpp +++ b/lib/linalg/zpptri.cpp @@ -1,13 +1,13 @@ /* fortran/zpptri.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -114,8 +114,8 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap, - integer *info, ftnlen uplo_len) +/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap, + integer *info, ftnlen uplo_len) { /* System generated locals */ integer i__1, i__2, i__3; @@ -126,17 +126,17 @@ f"> */ integer j, jc, jj; doublereal ajj; integer jjn; - extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, - doublecomplex *, integer *, doublecomplex *, ftnlen); + extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *, ftnlen); extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); logical upper; - extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, - doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *, - doublereal *, doublecomplex *, integer *), ztptri_(char *, char *, - integer *, doublecomplex *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *, + doublereal *, doublecomplex *, integer *), ztptri_(char *, char *, + integer *, doublecomplex *, integer *, ftnlen, ftnlen); /* -- LAPACK computational routine -- */ @@ -171,70 +171,70 @@ f"> */ *info = 0; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZPPTRI", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZPPTRI", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } /* Invert the triangular Cholesky factor U or L. */ ztptri_(uplo, (char *)"Non-unit", n, &ap[1], info, (ftnlen)1, (ftnlen)8); if (*info > 0) { - return 0; + return 0; } if (upper) { /* Compute the product inv(U) * inv(U)**H. */ - jj = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jc = jj + 1; - jj += j; - if (j > 1) { - i__2 = j - 1; - zhpr_((char *)"Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1], (ftnlen) - 5); - } - i__2 = jj; - ajj = ap[i__2].r; - zdscal_(&j, &ajj, &ap[jc], &c__1); + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + zhpr_((char *)"Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1], (ftnlen) + 5); + } + i__2 = jj; + ajj = ap[i__2].r; + zdscal_(&j, &ajj, &ap[jc], &c__1); /* L10: */ - } + } } else { /* Compute the product inv(L)**H * inv(L). */ - jj = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jjn = jj + *n - j + 1; - i__2 = jj; - i__3 = *n - j + 1; - zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1); - d__1 = z__1.r; - ap[i__2].r = d__1, ap[i__2].i = 0.; - if (j < *n) { - i__2 = *n - j; - ztpmv_((char *)"Lower", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[ - jjn], &ap[jj + 1], &c__1, (ftnlen)5, (ftnlen)19, ( - ftnlen)8); - } - jj = jjn; + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jjn = jj + *n - j + 1; + i__2 = jj; + i__3 = *n - j + 1; + zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1); + d__1 = z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + if (j < *n) { + i__2 = *n - j; + ztpmv_((char *)"Lower", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[ + jjn], &ap[jj + 1], &c__1, (ftnlen)5, (ftnlen)19, ( + ftnlen)8); + } + jj = jjn; /* L20: */ - } + } } return 0; @@ -244,5 +244,5 @@ f"> */ } /* zpptri_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zscal.cpp b/lib/linalg/zscal.cpp index 5985adebaf..6efc02ee5e 100644 --- a/lib/linalg/zscal.cpp +++ b/lib/linalg/zscal.cpp @@ -1,13 +1,13 @@ /* fortran/zscal.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -91,8 +91,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx, - integer *incx) +/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx, + integer *incx) { /* System generated locals */ integer i__1, i__2, i__3, i__4; @@ -122,34 +122,34 @@ extern "C" { /* Function Body */ if (*n <= 0 || *incx <= 0 || za->r == 1. && za->i == 0.) { - return 0; + return 0; } if (*incx == 1) { /* code for increment equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * - zx[i__3].i + za->i * zx[i__3].r; - zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * + zx[i__3].i + za->i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + } } else { /* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - i__3 = i__; - i__4 = i__; - z__1.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__1.i = za->r * - zx[i__4].i + za->i * zx[i__4].r; - zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; - } + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + z__1.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__1.i = za->r * + zx[i__4].i + za->i * zx[i__4].r; + zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; + } } return 0; @@ -158,5 +158,5 @@ extern "C" { } /* zscal_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zstedc.cpp b/lib/linalg/zstedc.cpp index fb52b344b1..1a4d71cf50 100644 --- a/lib/linalg/zstedc.cpp +++ b/lib/linalg/zstedc.cpp @@ -1,13 +1,13 @@ /* fortran/zstedc.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -236,10 +236,10 @@ f"> */ /* > at Berkeley, USA */ /* ===================================================================== */ -/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, - integer *liwork, integer *info, ftnlen compz_len) +/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, + integer *liwork, integer *info, ftnlen compz_len) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2, i__3, i__4; @@ -257,40 +257,40 @@ f"> */ doublereal eps, tiny; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer lwmin, start; - extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zlaed0_(integer *, integer *, - doublereal *, doublereal *, doublecomplex *, integer *, - doublecomplex *, integer *, doublereal *, integer *, integer *); + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaed0_(integer *, integer *, + doublereal *, doublereal *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, integer *, integer *); extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen), dstedc_(char *, integer *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *, integer *, ftnlen), dlaset_( - char *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen), xerbla_(char *, integer *, - ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen), dstedc_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, ftnlen), dlaset_( + char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen), xerbla_(char *, integer *, + ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer finish; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, - integer *), zlacrm_(integer *, integer *, doublecomplex *, - integer *, doublereal *, integer *, doublecomplex *, integer *, - doublereal *); + integer *), zlacrm_(integer *, integer *, doublecomplex *, + integer *, doublereal *, integer *, doublecomplex *, integer *, + doublereal *); integer liwmin, icompz; - extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - ftnlen), zlacpy_(char *, integer *, integer *, doublecomplex *, - integer *, doublecomplex *, integer *, ftnlen); + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + ftnlen), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen); doublereal orgnrm; integer lrwmin; logical lquery; integer smlsiz; - extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *, - doublereal *, doublecomplex *, integer *, doublereal *, integer *, - ftnlen); + extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublereal *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -333,88 +333,88 @@ f"> */ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { - icompz = 0; + icompz = 0; } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { - icompz = 1; + icompz = 1; } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { - icompz = 2; + icompz = 2; } else { - icompz = -1; + icompz = -1; } if (icompz < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; + *info = -6; } if (*info == 0) { /* Compute the workspace requirements */ - smlsiz = ilaenv_(&c__9, (char *)"ZSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( - ftnlen)6, (ftnlen)1); - if (*n <= 1 || icompz == 0) { - lwmin = 1; - liwmin = 1; - lrwmin = 1; - } else if (*n <= smlsiz) { - lwmin = 1; - liwmin = 1; - lrwmin = *n - 1 << 1; - } else if (icompz == 1) { - lgn = (integer) (log((doublereal) (*n)) / log(2.)); - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - lwmin = *n * *n; + smlsiz = ilaenv_(&c__9, (char *)"ZSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + lwmin = 1; + liwmin = 1; + lrwmin = 1; + } else if (*n <= smlsiz) { + lwmin = 1; + liwmin = 1; + lrwmin = *n - 1 << 1; + } else if (icompz == 1) { + lgn = (integer) (log((doublereal) (*n)) / log(2.)); + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + lwmin = *n * *n; /* Computing 2nd power */ - i__1 = *n; - lrwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); - liwmin = *n * 6 + 6 + *n * 5 * lgn; - } else if (icompz == 2) { - lwmin = 1; + i__1 = *n; + lrwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { + lwmin = 1; /* Computing 2nd power */ - i__1 = *n; - lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1); - liwmin = *n * 5 + 3; - } - work[1].r = (doublereal) lwmin, work[1].i = 0.; - rwork[1] = (doublereal) lrwmin; - iwork[1] = liwmin; + i__1 = *n; + lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } + work[1].r = (doublereal) lwmin, work[1].i = 0.; + rwork[1] = (doublereal) lrwmin; + iwork[1] = liwmin; - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*lrwork < lrwmin && ! lquery) { - *info = -10; - } else if (*liwork < liwmin && ! lquery) { - *info = -12; - } + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*lrwork < lrwmin && ! lquery) { + *info = -10; + } else if (*liwork < liwmin && ! lquery) { + *info = -12; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZSTEDC", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZSTEDC", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - if (icompz != 0) { - i__1 = z_dim1 + 1; - z__[i__1].r = 1., z__[i__1].i = 0.; - } - return 0; + if (icompz != 0) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; } /* If the following conditional clause is removed, then the routine */ @@ -429,8 +429,8 @@ f"> */ /* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */ if (icompz == 0) { - dsterf_(n, &d__[1], &e[1], info); - goto L70; + dsterf_(n, &d__[1], &e[1], info); + goto L70; } /* If N is smaller than the minimum divide size (SMLSIZ+1), then */ @@ -438,51 +438,51 @@ f"> */ if (*n <= smlsiz) { - zsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1], - info, (ftnlen)1); + zsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1], + info, (ftnlen)1); } else { /* If COMPZ = 'I', we simply call DSTEDC instead. */ - if (icompz == 2) { - dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &rwork[1], n, (ftnlen)4); - ll = *n * *n + 1; - i__1 = *lrwork - ll + 1; - dstedc_((char *)"I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, & - iwork[1], liwork, info, (ftnlen)1); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * z_dim1; - i__4 = (j - 1) * *n + i__; - z__[i__3].r = rwork[i__4], z__[i__3].i = 0.; + if (icompz == 2) { + dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &rwork[1], n, (ftnlen)4); + ll = *n * *n + 1; + i__1 = *lrwork - ll + 1; + dstedc_((char *)"I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, & + iwork[1], liwork, info, (ftnlen)1); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * z_dim1; + i__4 = (j - 1) * *n + i__; + z__[i__3].r = rwork[i__4], z__[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } - goto L70; - } + } + goto L70; + } /* From now on, only option left to be handled is COMPZ = 'V', */ /* i.e. ICOMPZ = 1. */ /* Scale. */ - orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); - if (orgnrm == 0.) { - goto L70; - } + orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); + if (orgnrm == 0.) { + goto L70; + } - eps = dlamch_((char *)"Epsilon", (ftnlen)7); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); - start = 1; + start = 1; /* while ( START <= N ) */ L30: - if (start <= *n) { + if (start <= *n) { /* Let FINISH be the position of the next subdiagonal entry */ /* such that E( FINISH ) <= TINY or FINISH = N if no such */ @@ -490,88 +490,88 @@ L30: /* between START and FINISH constitutes an independent */ /* sub-problem. */ - finish = start; + finish = start; L40: - if (finish < *n) { - tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( - d__2 = d__[finish + 1], abs(d__2))); - if ((d__1 = e[finish], abs(d__1)) > tiny) { - ++finish; - goto L40; - } - } + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( + d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L40; + } + } /* (Sub) Problem determined. Compute its size and solve it. */ - m = finish - start + 1; - if (m > smlsiz) { + m = finish - start + 1; + if (m > smlsiz) { /* Scale. */ - orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ - start], &m, info, (ftnlen)1); - i__1 = m - 1; - i__2 = m - 1; - dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ - start], &i__2, info, (ftnlen)1); + orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ + start], &m, info, (ftnlen)1); + i__1 = m - 1; + i__2 = m - 1; + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ + start], &i__2, info, (ftnlen)1); - zlaed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 + - 1], ldz, &work[1], n, &rwork[1], &iwork[1], info); - if (*info > 0) { - *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % - (m + 1) + start - 1; - goto L70; - } + zlaed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 + + 1], ldz, &work[1], n, &rwork[1], &iwork[1], info); + if (*info > 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % + (m + 1) + start - 1; + goto L70; + } /* Scale back. */ - dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ - start], &m, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ + start], &m, info, (ftnlen)1); - } else { - dsteqr_((char *)"I", &m, &d__[start], &e[start], &rwork[1], &m, & - rwork[m * m + 1], info, (ftnlen)1); - zlacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, & - work[1], n, &rwork[m * m + 1]); - zlacpy_((char *)"A", n, &m, &work[1], n, &z__[start * z_dim1 + 1], - ldz, (ftnlen)1); - if (*info > 0) { - *info = start * (*n + 1) + finish; - goto L70; - } - } + } else { + dsteqr_((char *)"I", &m, &d__[start], &e[start], &rwork[1], &m, & + rwork[m * m + 1], info, (ftnlen)1); + zlacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, & + work[1], n, &rwork[m * m + 1]); + zlacpy_((char *)"A", n, &m, &work[1], n, &z__[start * z_dim1 + 1], + ldz, (ftnlen)1); + if (*info > 0) { + *info = start * (*n + 1) + finish; + goto L70; + } + } - start = finish + 1; - goto L30; - } + start = finish + 1; + goto L30; + } /* endwhile */ /* Use Selection Sort to minimize swaps of eigenvectors */ - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } /* L50: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } /* L60: */ - } + } } L70: @@ -586,5 +586,5 @@ L70: } /* zstedc_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zsteqr.cpp b/lib/linalg/zsteqr.cpp index 21cb31cc10..ce75593d28 100644 --- a/lib/linalg/zsteqr.cpp +++ b/lib/linalg/zsteqr.cpp @@ -1,13 +1,13 @@ /* fortran/zsteqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -157,9 +157,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work, - integer *info, ftnlen compz_len) +/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work, + integer *info, ftnlen compz_len) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; @@ -177,39 +177,39 @@ f"> */ integer lsv; doublereal tst, eps2; integer lend, jtot; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); extern logical lsame_(char *, char *, ftnlen, ftnlen); doublereal anorm; - extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublecomplex *, integer *, - ftnlen, ftnlen, ftnlen), zswap_(integer *, doublecomplex *, - integer *, doublecomplex *, integer *), dlaev2_(doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *); + extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *, + ftnlen, ftnlen, ftnlen), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), dlaev2_(doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *); integer lendm1, lendp1; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, - ftnlen); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, + ftnlen); integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *, ftnlen); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, ftnlen); doublereal safmin; - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); doublereal safmax; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, - ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, + ftnlen); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *, ftnlen); integer lendsv; doublereal ssfmin; integer nmaxit, icompz; doublereal ssfmax; - extern /* Subroutine */ int zlaset_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, doublecomplex *, integer *, - ftnlen); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -249,39 +249,39 @@ f"> */ *info = 0; if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { - icompz = 0; + icompz = 0; } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { - icompz = 1; + icompz = 1; } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { - icompz = 2; + icompz = 2; } else { - icompz = -1; + icompz = -1; } if (icompz < 0) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; + *info = -6; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZSTEQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZSTEQR", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n == 0) { - return 0; + return 0; } if (*n == 1) { - if (icompz == 2) { - i__1 = z_dim1 + 1; - z__[i__1].r = 1., z__[i__1].i = 0.; - } - return 0; + if (icompz == 2) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; } /* Determine the unit roundoff and over/underflow thresholds. */ @@ -299,7 +299,7 @@ f"> */ /* matrix. */ if (icompz == 2) { - zlaset_((char *)"Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, (ftnlen)4); + zlaset_((char *)"Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, (ftnlen)4); } nmaxit = *n * 30; @@ -314,25 +314,25 @@ f"> */ L10: if (l1 > *n) { - goto L160; + goto L160; } if (l1 > 1) { - e[l1 - 1] = 0.; + e[l1 - 1] = 0.; } if (l1 <= nm1) { - i__1 = nm1; - for (m = l1; m <= i__1; ++m) { - tst = (d__1 = e[m], abs(d__1)); - if (tst == 0.) { - goto L30; - } - if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m - + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } /* L20: */ - } + } } m = *n; @@ -343,7 +343,7 @@ L30: lendsv = lend; l1 = m + 1; if (lend == l) { - goto L10; + goto L10; } /* Scale submatrix in rows and columns L to LEND */ @@ -352,31 +352,31 @@ L30: anorm = dlanst_((char *)"I", &i__1, &d__[l], &e[l], (ftnlen)1); iscale = 0; if (anorm == 0.) { - goto L10; + goto L10; } if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info, (ftnlen)1); - i__1 = lend - l; - dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info, (ftnlen)1); + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info, (ftnlen)1); } /* Choose between QL and QR iteration */ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; + lend = lsv; + l = lendsv; } if (lend > l) { @@ -386,120 +386,120 @@ L30: /* Look for small subdiagonal element. */ L40: - if (l != lend) { - lendm1 = lend - 1; - i__1 = lendm1; - for (m = l; m <= i__1; ++m) { + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { /* Computing 2nd power */ - d__2 = (d__1 = e[m], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - + 1], abs(d__2)) + safmin) { - goto L60; - } + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + + 1], abs(d__2)) + safmin) { + goto L60; + } /* L50: */ - } - } + } + } - m = lend; + m = lend; L60: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L80; - } + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } /* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ /* to compute its eigensystem. */ - if (m == l + 1) { - if (icompz > 0) { - dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); - work[l] = c__; - work[*n - 1 + l] = s; - zlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], & - z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, ( - ftnlen)1); - } else { - dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); - } - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L40; - } - goto L140; - } + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + zlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], & + z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, ( + ftnlen)1); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } - if (jtot == nmaxit) { - goto L140; - } - ++jtot; + if (jtot == nmaxit) { + goto L140; + } + ++jtot; /* Form shift. */ - g = (d__[l + 1] - p) / (e[l] * 2.); - r__ = dlapy2_(&g, &c_b41); - g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b41); + g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); - s = 1.; - c__ = 1.; - p = 0.; + s = 1.; + c__ = 1.; + p = 0.; /* Inner loop */ - mm1 = m - 1; - i__1 = l; - for (i__ = mm1; i__ >= i__1; --i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m - 1) { - e[i__ + 1] = r__; - } - g = d__[i__ + 1] - p; - r__ = (d__[i__] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__ + 1] = g + p; - g = c__ * r__ - b; + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; /* If eigenvectors are desired, then save rotations. */ - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = -s; - } + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } /* L70: */ - } + } /* If eigenvectors are desired, then apply saved rotations. */ - if (icompz > 0) { - mm = m - l + 1; - zlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l - * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (icompz > 0) { + mm = m - l + 1; + zlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l + * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } - d__[l] -= p; - e[l] = g; - goto L40; + d__[l] -= p; + e[l] = g; + goto L40; /* Eigenvalue found. */ L80: - d__[l] = p; + d__[l] = p; - ++l; - if (l <= lend) { - goto L40; - } - goto L140; + ++l; + if (l <= lend) { + goto L40; + } + goto L140; } else { @@ -508,121 +508,121 @@ L80: /* Look for small superdiagonal element. */ L90: - if (l != lend) { - lendp1 = lend + 1; - i__1 = lendp1; - for (m = l; m >= i__1; --m) { + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { /* Computing 2nd power */ - d__2 = (d__1 = e[m - 1], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - - 1], abs(d__2)) + safmin) { - goto L110; - } + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + - 1], abs(d__2)) + safmin) { + goto L110; + } /* L100: */ - } - } + } + } - m = lend; + m = lend; L110: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L130; - } + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } /* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ /* to compute its eigensystem. */ - if (m == l - 1) { - if (icompz > 0) { - dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) - ; - work[m] = c__; - work[*n - 1 + m] = s; - zlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], & - z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, - (ftnlen)1); - } else { - dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); - } - d__[l - 1] = rt1; - d__[l] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L90; - } - goto L140; - } + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) + ; + work[m] = c__; + work[*n - 1 + m] = s; + zlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], & + z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } - if (jtot == nmaxit) { - goto L140; - } - ++jtot; + if (jtot == nmaxit) { + goto L140; + } + ++jtot; /* Form shift. */ - g = (d__[l - 1] - p) / (e[l - 1] * 2.); - r__ = dlapy2_(&g, &c_b41); - g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b41); + g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); - s = 1.; - c__ = 1.; - p = 0.; + s = 1.; + c__ = 1.; + p = 0.; /* Inner loop */ - lm1 = l - 1; - i__1 = lm1; - for (i__ = m; i__ <= i__1; ++i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m) { - e[i__ - 1] = r__; - } - g = d__[i__] - p; - r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__] = g + p; - g = c__ * r__ - b; + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; /* If eigenvectors are desired, then save rotations. */ - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = s; - } + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } /* L120: */ - } + } /* If eigenvectors are desired, then apply saved rotations. */ - if (icompz > 0) { - mm = l - m + 1; - zlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m - * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); - } + if (icompz > 0) { + mm = l - m + 1; + zlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m + * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } - d__[l] -= p; - e[lm1] = g; - goto L90; + d__[l] -= p; + e[lm1] = g; + goto L90; /* Eigenvalue found. */ L130: - d__[l] = p; + d__[l] = p; - --l; - if (l >= lend) { - goto L90; - } - goto L140; + --l; + if (l >= lend) { + goto L90; + } + goto L140; } @@ -630,33 +630,33 @@ L130: L140: if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); - i__1 = lendsv - lsv; - dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, - info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, + info, (ftnlen)1); } else if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info, (ftnlen)1); - i__1 = lendsv - lsv; - dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, - info, (ftnlen)1); + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, + info, (ftnlen)1); } /* Check for no convergence to an eigenvalue after a total */ /* of N*MAXIT iterations. */ if (jtot == nmaxit) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } /* L150: */ - } - return 0; + } + return 0; } goto L10; @@ -667,33 +667,33 @@ L160: /* Use Quick Sort */ - dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); } else { /* Use Selection Sort to minimize swaps of eigenvectors */ - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } /* L170: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } /* L180: */ - } + } } return 0; @@ -702,5 +702,5 @@ L160: } /* zsteqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zswap.cpp b/lib/linalg/zswap.cpp index d00bb044fd..ff04833b04 100644 --- a/lib/linalg/zswap.cpp +++ b/lib/linalg/zswap.cpp @@ -1,13 +1,13 @@ /* fortran/zswap.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -94,8 +94,8 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx, - doublecomplex *zy, integer *incy) +/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy) { /* System generated locals */ integer i__1, i__2, i__3; @@ -124,46 +124,46 @@ extern "C" { /* Function Body */ if (*n <= 0) { - return 0; + return 0; } if (*incx == 1 && *incy == 1) { /* code for both increments equal to 1 */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; - i__2 = i__; - i__3 = i__; - zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; - i__2 = i__; - zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; - } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = i__; + i__3 = i__; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = i__; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; + } } else { /* code for unequal increments or equal increments not equal */ /* to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = ix; - ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; - i__2 = ix; - i__3 = iy; - zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; - i__2 = iy; - zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; - ix += *incx; - iy += *incy; - } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = ix; + i__3 = iy; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = iy; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; + ix += *incx; + iy += *incy; + } } return 0; @@ -172,5 +172,5 @@ extern "C" { } /* zswap_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ztpmv.cpp b/lib/linalg/ztpmv.cpp index a29145d6bd..adb1db10f4 100644 --- a/lib/linalg/ztpmv.cpp +++ b/lib/linalg/ztpmv.cpp @@ -1,13 +1,13 @@ /* fortran/ztpmv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -155,9 +155,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int ztpmv_(char *uplo, char *trans, char *diag, integer *n, - doublecomplex *ap, doublecomplex *x, integer *incx, ftnlen uplo_len, - ftnlen trans_len, ftnlen diag_len) +/* Subroutine */ int ztpmv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *ap, doublecomplex *x, integer *incx, ftnlen uplo_len, + ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; @@ -205,29 +205,29 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 3; + ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*incx == 0) { - info = 7; + info = 7; } if (info != 0) { - xerbla_((char *)"ZTPMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZTPMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); @@ -237,9 +237,9 @@ extern "C" { /* will be ( N - 1 )*INCX too small for descending loops. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of AP are */ @@ -249,383 +249,383 @@ extern "C" { /* Form x:= A*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] - .i, z__2.i = temp.r * ap[i__5].i + temp.i - * ap[i__5].r; - z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - ++k; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; /* L10: */ - } - if (nounit) { - i__2 = j; - i__3 = j; - i__4 = kk + j - 1; - z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ - i__4].i, z__1.i = x[i__3].r * ap[i__4].i - + x[i__3].i * ap[i__4].r; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - } - kk += j; + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, z__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + kk += j; /* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - i__3 = ix; - i__4 = ix; - i__5 = k; - z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] - .i, z__2.i = temp.r * ap[i__5].i + temp.i - * ap[i__5].r; - z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; /* L30: */ - } - if (nounit) { - i__2 = jx; - i__3 = jx; - i__4 = kk + j - 1; - z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ - i__4].i, z__1.i = x[i__3].r * ap[i__4].i - + x[i__3].i * ap[i__4].r; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - } - jx += *incx; - kk += j; + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, z__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; + kk += j; /* L40: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - k = kk; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - i__2 = i__; - i__3 = i__; - i__4 = k; - z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] - .i, z__2.i = temp.r * ap[i__4].i + temp.i - * ap[i__4].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - --k; + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + --k; /* L50: */ - } - if (nounit) { - i__1 = j; - i__2 = j; - i__3 = kk - *n + j; - z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ - i__3].i, z__1.i = x[i__2].r * ap[i__3].i - + x[i__2].i * ap[i__3].r; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - } - kk -= *n - j + 1; + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, z__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + kk -= *n - j + 1; /* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = kx; - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - i__2 = ix; - i__3 = ix; - i__4 = k; - z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] - .i, z__2.i = temp.r * ap[i__4].i + temp.i - * ap[i__4].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - ix -= *incx; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; /* L70: */ - } - if (nounit) { - i__1 = jx; - i__2 = jx; - i__3 = kk - *n + j; - z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ - i__3].i, z__1.i = x[i__2].r * ap[i__3].i - + x[i__2].i * ap[i__3].r; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - } - jx -= *incx; - kk -= *n - j + 1; + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, z__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; + kk -= *n - j + 1; /* L80: */ - } - } - } + } + } + } } else { /* Form x := A**T*x or x := A**H*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - k = kk - 1; - if (noconj) { - if (nounit) { - i__1 = kk; - z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] - .i, z__1.i = temp.r * ap[i__1].i + temp.i - * ap[i__1].r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - i__1 = k; - i__2 = i__; - z__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[ - i__2].i, z__2.i = ap[i__1].r * x[i__2].i - + ap[i__1].i * x[i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - --k; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, z__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = k; + i__2 = i__; + z__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[ + i__2].i, z__2.i = ap[i__1].r * x[i__2].i + + ap[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; /* L90: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &ap[kk]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - d_cnjg(&z__3, &ap[k]); - i__1 = i__; - z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, - z__2.i = z__3.r * x[i__1].i + z__3.i * x[ - i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - --k; + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_cnjg(&z__3, &ap[k]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; /* L100: */ - } - } - i__1 = j; - x[i__1].r = temp.r, x[i__1].i = temp.i; - kk -= j; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= j; /* L110: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = jx; - if (noconj) { - if (nounit) { - i__1 = kk; - z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] - .i, z__1.i = temp.r * ap[i__1].i + temp.i - * ap[i__1].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - i__2 = k; - i__3 = ix; - z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ - i__3].i, z__2.i = ap[i__2].r * x[i__3].i - + ap[i__2].i * x[i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, z__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L120: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &ap[kk]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - d_cnjg(&z__3, &ap[k]); - i__2 = ix; - z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, - z__2.i = z__3.r * x[i__2].i + z__3.i * x[ - i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + d_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L130: */ - } - } - i__1 = jx; - x[i__1].r = temp.r, x[i__1].i = temp.i; - jx -= *incx; - kk -= j; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= j; /* L140: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - k = kk + 1; - if (noconj) { - if (nounit) { - i__2 = kk; - z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] - .i, z__1.i = temp.r * ap[i__2].i + temp.i - * ap[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = k; - i__4 = i__; - z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ - i__4].i, z__2.i = ap[i__3].r * x[i__4].i - + ap[i__3].i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ++k; + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, z__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; /* L150: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &ap[kk]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - d_cnjg(&z__3, &ap[k]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ++k; + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; /* L160: */ - } - } - i__2 = j; - x[i__2].r = temp.r, x[i__2].i = temp.i; - kk += *n - j + 1; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += *n - j + 1; /* L170: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = jx; - if (noconj) { - if (nounit) { - i__2 = kk; - z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] - .i, z__1.i = temp.r * ap[i__2].i + temp.i - * ap[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - i__3 = k; - i__4 = ix; - z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ - i__4].i, z__2.i = ap[i__3].r * x[i__4].i - + ap[i__3].i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, z__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L180: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &ap[kk]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - d_cnjg(&z__3, &ap[k]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L190: */ - } - } - i__2 = jx; - x[i__2].r = temp.r, x[i__2].i = temp.i; - jx += *incx; - kk += *n - j + 1; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += *n - j + 1; /* L200: */ - } - } - } + } + } + } } return 0; @@ -635,5 +635,5 @@ extern "C" { } /* ztpmv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ztpsv.cpp b/lib/linalg/ztpsv.cpp index 7e7e64d721..c3c564acd2 100644 --- a/lib/linalg/ztpsv.cpp +++ b/lib/linalg/ztpsv.cpp @@ -1,13 +1,13 @@ /* fortran/ztpsv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -157,9 +157,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int ztpsv_(char *uplo, char *trans, char *diag, integer *n, - doublecomplex *ap, doublecomplex *x, integer *incx, ftnlen uplo_len, - ftnlen trans_len, ftnlen diag_len) +/* Subroutine */ int ztpsv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *ap, doublecomplex *x, integer *incx, ftnlen uplo_len, + ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; @@ -167,7 +167,7 @@ extern "C" { /* Builtin functions */ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( - doublecomplex *, doublecomplex *); + doublecomplex *, doublecomplex *); /* Local variables */ integer i__, j, k, kk, ix, jx, kx, info; @@ -208,29 +208,29 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 3; + ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*incx == 0) { - info = 7; + info = 7; } if (info != 0) { - xerbla_((char *)"ZTPSV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZTPSV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); @@ -240,9 +240,9 @@ extern "C" { /* will be ( N - 1 )*INCX too small for descending loops. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of AP are */ @@ -252,348 +252,348 @@ extern "C" { /* Form x := inv( A )*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - if (nounit) { - i__1 = j; - z_div(&z__1, &x[j], &ap[kk]); - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - k = kk - 1; - for (i__ = j - 1; i__ >= 1; --i__) { - i__1 = i__; - i__2 = i__; - i__3 = k; - z__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3] - .i, z__2.i = temp.r * ap[i__3].i + temp.i - * ap[i__3].r; - z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - - z__2.i; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - --k; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = j; + z_div(&z__1, &x[j], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = k; + z__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3] + .i, z__2.i = temp.r * ap[i__3].i + temp.i + * ap[i__3].r; + z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - + z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + --k; /* L10: */ - } - } - kk -= j; + } + } + kk -= j; /* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - if (nounit) { - i__1 = jx; - z_div(&z__1, &x[jx], &ap[kk]); - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = jx; - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - i__2 = ix; - i__3 = ix; - i__4 = k; - z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] - .i, z__2.i = temp.r * ap[i__4].i + temp.i - * ap[i__4].r; - z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = jx; + z_div(&z__1, &x[jx], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* L30: */ - } - } - jx -= *incx; - kk -= j; + } + } + jx -= *incx; + kk -= j; /* L40: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - if (nounit) { - i__2 = j; - z_div(&z__1, &x[j], &ap[kk]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] - .i, z__2.i = temp.r * ap[i__5].i + temp.i - * ap[i__5].r; - z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - ++k; + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = j; + z_div(&z__1, &x[j], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; /* L50: */ - } - } - kk += *n - j + 1; + } + } + kk += *n - j + 1; /* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - if (nounit) { - i__2 = jx; - z_div(&z__1, &x[jx], &ap[kk]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = jx; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - i__3 = ix; - i__4 = ix; - i__5 = k; - z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] - .i, z__2.i = temp.r * ap[i__5].i + temp.i - * ap[i__5].r; - z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = jx; + z_div(&z__1, &x[jx], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; /* L70: */ - } - } - jx += *incx; - kk += *n - j + 1; + } + } + jx += *incx; + kk += *n - j + 1; /* L80: */ - } - } - } + } + } + } } else { /* Form x := inv( A**T )*x or x := inv( A**H )*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - k = kk; - if (noconj) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = k; - i__4 = i__; - z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ - i__4].i, z__2.i = ap[i__3].r * x[i__4].i - + ap[i__3].i * x[i__4].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ++k; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; /* L90: */ - } - if (nounit) { - z_div(&z__1, &temp, &ap[kk + j - 1]); - temp.r = z__1.r, temp.i = z__1.i; - } - } else { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - d_cnjg(&z__3, &ap[k]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ++k; + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; /* L100: */ - } - if (nounit) { - d_cnjg(&z__2, &ap[kk + j - 1]); - z_div(&z__1, &temp, &z__2); - temp.r = z__1.r, temp.i = z__1.i; - } - } - i__2 = j; - x[i__2].r = temp.r, x[i__2].i = temp.i; - kk += j; + } + if (nounit) { + d_cnjg(&z__2, &ap[kk + j - 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += j; /* L110: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = kx; - if (noconj) { - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - i__3 = k; - i__4 = ix; - z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ - i__4].i, z__2.i = ap[i__3].r * x[i__4].i - + ap[i__3].i * x[i__4].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + if (noconj) { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; /* L120: */ - } - if (nounit) { - z_div(&z__1, &temp, &ap[kk + j - 1]); - temp.r = z__1.r, temp.i = z__1.i; - } - } else { - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - d_cnjg(&z__3, &ap[k]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; /* L130: */ - } - if (nounit) { - d_cnjg(&z__2, &ap[kk + j - 1]); - z_div(&z__1, &temp, &z__2); - temp.r = z__1.r, temp.i = z__1.i; - } - } - i__2 = jx; - x[i__2].r = temp.r, x[i__2].i = temp.i; - jx += *incx; - kk += j; + } + if (nounit) { + d_cnjg(&z__2, &ap[kk + j - 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += j; /* L140: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - k = kk; - if (noconj) { - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - i__2 = k; - i__3 = i__; - z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ - i__3].i, z__2.i = ap[i__2].r * x[i__3].i - + ap[i__2].i * x[i__3].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - --k; + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = k; + i__3 = i__; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; /* L150: */ - } - if (nounit) { - z_div(&z__1, &temp, &ap[kk - *n + j]); - temp.r = z__1.r, temp.i = z__1.i; - } - } else { - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - d_cnjg(&z__3, &ap[k]); - i__2 = i__; - z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, - z__2.i = z__3.r * x[i__2].i + z__3.i * x[ - i__2].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - --k; + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + d_cnjg(&z__3, &ap[k]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; /* L160: */ - } - if (nounit) { - d_cnjg(&z__2, &ap[kk - *n + j]); - z_div(&z__1, &temp, &z__2); - temp.r = z__1.r, temp.i = z__1.i; - } - } - i__1 = j; - x[i__1].r = temp.r, x[i__1].i = temp.i; - kk -= *n - j + 1; + } + if (nounit) { + d_cnjg(&z__2, &ap[kk - *n + j]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= *n - j + 1; /* L170: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = kx; - if (noconj) { - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - i__2 = k; - i__3 = ix; - z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ - i__3].i, z__2.i = ap[i__2].r * x[i__3].i - + ap[i__2].i * x[i__3].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix -= *incx; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + if (noconj) { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; /* L180: */ - } - if (nounit) { - z_div(&z__1, &temp, &ap[kk - *n + j]); - temp.r = z__1.r, temp.i = z__1.i; - } - } else { - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - d_cnjg(&z__3, &ap[k]); - i__2 = ix; - z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, - z__2.i = z__3.r * x[i__2].i + z__3.i * x[ - i__2].r; - z__1.r = temp.r - z__2.r, z__1.i = temp.i - - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix -= *incx; + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + d_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; /* L190: */ - } - if (nounit) { - d_cnjg(&z__2, &ap[kk - *n + j]); - z_div(&z__1, &temp, &z__2); - temp.r = z__1.r, temp.i = z__1.i; - } - } - i__1 = jx; - x[i__1].r = temp.r, x[i__1].i = temp.i; - jx -= *incx; - kk -= *n - j + 1; + } + if (nounit) { + d_cnjg(&z__2, &ap[kk - *n + j]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= *n - j + 1; /* L200: */ - } - } - } + } + } + } } return 0; @@ -603,5 +603,5 @@ extern "C" { } /* ztpsv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ztptri.cpp b/lib/linalg/ztptri.cpp index c781cb964f..eb5c2988e3 100644 --- a/lib/linalg/ztptri.cpp +++ b/lib/linalg/ztptri.cpp @@ -1,13 +1,13 @@ /* fortran/ztptri.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -138,8 +138,8 @@ f"> */ /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n, - doublecomplex *ap, integer *info, ftnlen uplo_len, ftnlen diag_len) +/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n, + doublecomplex *ap, integer *info, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ integer i__1, i__2; @@ -152,12 +152,12 @@ f"> */ integer j, jc, jj; doublecomplex ajj; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); logical upper; - extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, - doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); + extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); integer jclast; logical nounit; @@ -193,108 +193,108 @@ f"> */ upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! nounit && ! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*n < 0) { - *info = -3; + *info = -3; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZTPTRI", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZTPTRI", &i__1, (ftnlen)6); + return 0; } /* Check for singularity if non-unit. */ if (nounit) { - if (upper) { - jj = 0; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - jj += *info; - i__2 = jj; - if (ap[i__2].r == 0. && ap[i__2].i == 0.) { - return 0; - } + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + i__2 = jj; + if (ap[i__2].r == 0. && ap[i__2].i == 0.) { + return 0; + } /* L10: */ - } - } else { - jj = 1; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - i__2 = jj; - if (ap[i__2].r == 0. && ap[i__2].i == 0.) { - return 0; - } - jj = jj + *n - *info + 1; + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = jj; + if (ap[i__2].r == 0. && ap[i__2].i == 0.) { + return 0; + } + jj = jj + *n - *info + 1; /* L20: */ - } - } - *info = 0; + } + } + *info = 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ - jc = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - i__2 = jc + j - 1; - z_div(&z__1, &c_b1, &ap[jc + j - 1]); - ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; - i__2 = jc + j - 1; - z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i; - ajj.r = z__1.r, ajj.i = z__1.i; - } else { - z__1.r = -1., z__1.i = -0.; - ajj.r = z__1.r, ajj.i = z__1.i; - } + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + i__2 = jc + j - 1; + z_div(&z__1, &c_b1, &ap[jc + j - 1]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = jc + j - 1; + z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i; + ajj.r = z__1.r, ajj.i = z__1.i; + } else { + z__1.r = -1., z__1.i = -0.; + ajj.r = z__1.r, ajj.i = z__1.i; + } /* Compute elements 1:j-1 of j-th column. */ - i__2 = j - 1; - ztpmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &ap[1], &ap[jc], & - c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); - i__2 = j - 1; - zscal_(&i__2, &ajj, &ap[jc], &c__1); - jc += j; + i__2 = j - 1; + ztpmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &ap[1], &ap[jc], & + c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__2 = j - 1; + zscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; /* L30: */ - } + } } else { /* Compute inverse of lower triangular matrix. */ - jc = *n * (*n + 1) / 2; - for (j = *n; j >= 1; --j) { - if (nounit) { - i__1 = jc; - z_div(&z__1, &c_b1, &ap[jc]); - ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; - i__1 = jc; - z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i; - ajj.r = z__1.r, ajj.i = z__1.i; - } else { - z__1.r = -1., z__1.i = -0.; - ajj.r = z__1.r, ajj.i = z__1.i; - } - if (j < *n) { + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + i__1 = jc; + z_div(&z__1, &c_b1, &ap[jc]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = jc; + z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i; + ajj.r = z__1.r, ajj.i = z__1.i; + } else { + z__1.r = -1., z__1.i = -0.; + ajj.r = z__1.r, ajj.i = z__1.i; + } + if (j < *n) { /* Compute elements j+1:n of j-th column. */ - i__1 = *n - j; - ztpmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &ap[jclast], &ap[ - jc + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); - i__1 = *n - j; - zscal_(&i__1, &ajj, &ap[jc + 1], &c__1); - } - jclast = jc; - jc = jc - *n + j - 2; + i__1 = *n - j; + ztpmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &ap[jclast], &ap[ + jc + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__1 = *n - j; + zscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; /* L40: */ - } + } } return 0; @@ -304,5 +304,5 @@ f"> */ } /* ztptri_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ztrmm.cpp b/lib/linalg/ztrmm.cpp index cd71371d5b..3fec24189e 100644 --- a/lib/linalg/ztrmm.cpp +++ b/lib/linalg/ztrmm.cpp @@ -1,13 +1,13 @@ /* fortran/ztrmm.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -190,14 +190,14 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, - integer *lda, doublecomplex *b, integer *ldb, ftnlen side_len, ftnlen - uplo_len, ftnlen transa_len, ftnlen diag_len) +/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb, ftnlen side_len, ftnlen + uplo_len, ftnlen transa_len, ftnlen diag_len) { /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, - i__6; + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, + i__6; doublecomplex z__1, z__2, z__3; /* Builtin functions */ @@ -249,9 +249,9 @@ extern "C" { /* Function Body */ lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); if (lside) { - nrowa = *m; + nrowa = *m; } else { - nrowa = *n; + nrowa = *n; } noconj = lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); @@ -259,496 +259,496 @@ extern "C" { info = 0; if (! lside && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - info = 1; + info = 1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - info = 2; + info = 2; } else if (! lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 3; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 4; + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 3; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; } else if (*m < 0) { - info = 5; + info = 5; } else if (*n < 0) { - info = 6; + info = 6; } else if (*lda < max(1,nrowa)) { - info = 9; + info = 9; } else if (*ldb < max(1,*m)) { - info = 11; + info = 11; } if (info != 0) { - xerbla_((char *)"ZTRMM ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZTRMM ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0) { - return 0; + return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0. && alpha->i == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - b[i__3].r = 0., b[i__3].i = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } - return 0; + } + return 0; } /* Start the operations. */ if (lside) { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*A*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - i__3 = k + j * b_dim1; - if (b[i__3].r != 0. || b[i__3].i != 0.) { - i__3 = k + j * b_dim1; - z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] - .i, z__1.i = alpha->r * b[i__3].i + - alpha->i * b[i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * b_dim1; - i__5 = i__ + j * b_dim1; - i__6 = i__ + k * a_dim1; - z__2.r = temp.r * a[i__6].r - temp.i * a[i__6] - .i, z__2.i = temp.r * a[i__6].i + - temp.i * a[i__6].r; - z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] - .i + z__2.i; - b[i__4].r = z__1.r, b[i__4].i = z__1.i; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + i__3 = k + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, z__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6] + .i, z__2.i = temp.r * a[i__6].i + + temp.i * a[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; /* L30: */ - } - if (nounit) { - i__3 = k + k * a_dim1; - z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] - .i, z__1.i = temp.r * a[i__3].i + - temp.i * a[i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__3 = k + j * b_dim1; - b[i__3].r = temp.r, b[i__3].i = temp.i; - } + } + if (nounit) { + i__3 = k + k * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, z__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = k + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + } /* L40: */ - } + } /* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - i__2 = k + j * b_dim1; - if (b[i__2].r != 0. || b[i__2].i != 0.) { - i__2 = k + j * b_dim1; - z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2] - .i, z__1.i = alpha->r * b[i__2].i + - alpha->i * b[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = k + j * b_dim1; - b[i__2].r = temp.r, b[i__2].i = temp.i; - if (nounit) { - i__2 = k + j * b_dim1; - i__3 = k + j * b_dim1; - i__4 = k + k * a_dim1; - z__1.r = b[i__3].r * a[i__4].r - b[i__3].i * - a[i__4].i, z__1.i = b[i__3].r * a[ - i__4].i + b[i__3].i * a[i__4].r; - b[i__2].r = z__1.r, b[i__2].i = z__1.i; - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * b_dim1; - i__5 = i__ + k * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5] - .i, z__2.i = temp.r * a[i__5].i + - temp.i * a[i__5].r; - z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] - .i + z__2.i; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0. || b[i__2].i != 0.) { + i__2 = k + j * b_dim1; + z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2] + .i, z__1.i = alpha->r * b[i__2].i + + alpha->i * b[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = k + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; + if (nounit) { + i__2 = k + j * b_dim1; + i__3 = k + j * b_dim1; + i__4 = k + k * a_dim1; + z__1.r = b[i__3].r * a[i__4].r - b[i__3].i * + a[i__4].i, z__1.i = b[i__3].r * a[ + i__4].i + b[i__3].i * a[i__4].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5] + .i, z__2.i = temp.r * a[i__5].i + + temp.i * a[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L60: */ - } - } + } + } /* L70: */ - } + } /* L80: */ - } - } - } else { + } + } + } else { /* Form B := alpha*A**T*B or B := alpha*A**H*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - i__2 = i__ + j * b_dim1; - temp.r = b[i__2].r, temp.i = b[i__2].i; - if (noconj) { - if (nounit) { - i__2 = i__ + i__ * a_dim1; - z__1.r = temp.r * a[i__2].r - temp.i * a[i__2] - .i, z__1.i = temp.r * a[i__2].i + - temp.i * a[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - i__3 = k + i__ * a_dim1; - i__4 = k + j * b_dim1; - z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * - b[i__4].i, z__2.i = a[i__3].r * b[ - i__4].i + a[i__3].i * b[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + temp.r = b[i__2].r, temp.i = b[i__2].i; + if (noconj) { + if (nounit) { + i__2 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2] + .i, z__1.i = temp.r * a[i__2].i + + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * + b[i__4].i, z__2.i = a[i__3].r * b[ + i__4].i + a[i__3].i * b[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L90: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - d_cnjg(&z__3, &a[k + i__ * a_dim1]); - i__3 = k + j * b_dim1; - z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3] - .i, z__2.i = z__3.r * b[i__3].i + - z__3.i * b[i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3] + .i, z__2.i = z__3.r * b[i__3].i + + z__3.i * b[i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L100: */ - } - } - i__2 = i__ + j * b_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L110: */ - } + } /* L120: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - temp.r = b[i__3].r, temp.i = b[i__3].i; - if (noconj) { - if (nounit) { - i__3 = i__ + i__ * a_dim1; - z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] - .i, z__1.i = temp.r * a[i__3].i + - temp.i * a[i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - i__4 = k + i__ * a_dim1; - i__5 = k + j * b_dim1; - z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * - b[i__5].i, z__2.i = a[i__4].r * b[ - i__5].i + a[i__4].i * b[i__5].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + temp.r = b[i__3].r, temp.i = b[i__3].i; + if (noconj) { + if (nounit) { + i__3 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, z__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * + b[i__5].i, z__2.i = a[i__4].r * b[ + i__5].i + a[i__4].i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L130: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - d_cnjg(&z__3, &a[k + i__ * a_dim1]); - i__4 = k + j * b_dim1; - z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4] - .i, z__2.i = z__3.r * b[i__4].i + - z__3.i * b[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4] + .i, z__2.i = z__3.r * b[i__4].i + + z__3.i * b[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L140: */ - } - } - i__3 = i__ + j * b_dim1; - z__1.r = alpha->r * temp.r - alpha->i * temp.i, - z__1.i = alpha->r * temp.i + alpha->i * - temp.r; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L150: */ - } + } /* L160: */ - } - } - } + } + } + } } else { - if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { /* Form B := alpha*B*A. */ - if (upper) { - for (j = *n; j >= 1; --j) { - temp.r = alpha->r, temp.i = alpha->i; - if (nounit) { - i__1 = j + j * a_dim1; - z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, - z__1.i = temp.r * a[i__1].i + temp.i * a[i__1] - .r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + j * b_dim1; - i__3 = i__ + j * b_dim1; - z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, - z__1.i = temp.r * b[i__3].i + temp.i * b[i__3] - .r; - b[i__2].r = z__1.r, b[i__2].i = z__1.i; + if (upper) { + for (j = *n; j >= 1; --j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1] + .r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[i__3] + .r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L170: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - i__2 = k + j * a_dim1; - if (a[i__2].r != 0. || a[i__2].i != 0.) { - i__2 = k + j * a_dim1; - z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2] - .i, z__1.i = alpha->r * a[i__2].i + - alpha->i * a[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * b_dim1; - i__5 = i__ + k * b_dim1; - z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] - .i, z__2.i = temp.r * b[i__5].i + - temp.i * b[i__5].r; - z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] - .i + z__2.i; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + i__2 = k + j * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2] + .i, z__1.i = alpha->r * a[i__2].i + + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, z__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L180: */ - } - } + } + } /* L190: */ - } + } /* L200: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp.r = alpha->r, temp.i = alpha->i; - if (nounit) { - i__2 = j + j * a_dim1; - z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__1.i = temp.r * a[i__2].i + temp.i * a[i__2] - .r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * b_dim1; - z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, - z__1.i = temp.r * b[i__4].i + temp.i * b[i__4] - .r; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2] + .r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[i__4] + .r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L210: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - i__3 = k + j * a_dim1; - if (a[i__3].r != 0. || a[i__3].i != 0.) { - i__3 = k + j * a_dim1; - z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3] - .i, z__1.i = alpha->r * a[i__3].i + - alpha->i * a[i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * b_dim1; - i__5 = i__ + j * b_dim1; - i__6 = i__ + k * b_dim1; - z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] - .i, z__2.i = temp.r * b[i__6].i + - temp.i * b[i__6].r; - z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] - .i + z__2.i; - b[i__4].r = z__1.r, b[i__4].i = z__1.i; + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3] + .i, z__1.i = alpha->r * a[i__3].i + + alpha->i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, z__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; /* L220: */ - } - } + } + } /* L230: */ - } + } /* L240: */ - } - } - } else { + } + } + } else { /* Form B := alpha*B*A**T or B := alpha*B*A**H. */ - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + k * a_dim1; - if (a[i__3].r != 0. || a[i__3].i != 0.) { - if (noconj) { - i__3 = j + k * a_dim1; - z__1.r = alpha->r * a[i__3].r - alpha->i * a[ - i__3].i, z__1.i = alpha->r * a[i__3] - .i + alpha->i * a[i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - } else { - d_cnjg(&z__2, &a[j + k * a_dim1]); - z__1.r = alpha->r * z__2.r - alpha->i * - z__2.i, z__1.i = alpha->r * z__2.i + - alpha->i * z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__ + j * b_dim1; - i__5 = i__ + j * b_dim1; - i__6 = i__ + k * b_dim1; - z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] - .i, z__2.i = temp.r * b[i__6].i + - temp.i * b[i__6].r; - z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] - .i + z__2.i; - b[i__4].r = z__1.r, b[i__4].i = z__1.i; + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + if (noconj) { + i__3 = j + k * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[ + i__3].i, z__1.i = alpha->r * a[i__3] + .i + alpha->i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * + z__2.i, z__1.i = alpha->r * z__2.i + + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, z__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; /* L250: */ - } - } + } + } /* L260: */ - } - temp.r = alpha->r, temp.i = alpha->i; - if (nounit) { - if (noconj) { - i__2 = k + k * a_dim1; - z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__1.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } else { - d_cnjg(&z__2, &a[k + k * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - } - if (temp.r != 1. || temp.i != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + k * b_dim1; - i__4 = i__ + k * b_dim1; - z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, - z__1.i = temp.r * b[i__4].i + temp.i * b[ - i__4].r; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__2 = k + k * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L270: */ - } - } + } + } /* L280: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - i__2 = j + k * a_dim1; - if (a[i__2].r != 0. || a[i__2].i != 0.) { - if (noconj) { - i__2 = j + k * a_dim1; - z__1.r = alpha->r * a[i__2].r - alpha->i * a[ - i__2].i, z__1.i = alpha->r * a[i__2] - .i + alpha->i * a[i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } else { - d_cnjg(&z__2, &a[j + k * a_dim1]); - z__1.r = alpha->r * z__2.r - alpha->i * - z__2.i, z__1.i = alpha->r * z__2.i + - alpha->i * z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * b_dim1; - i__4 = i__ + j * b_dim1; - i__5 = i__ + k * b_dim1; - z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] - .i, z__2.i = temp.r * b[i__5].i + - temp.i * b[i__5].r; - z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] - .i + z__2.i; - b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + if (noconj) { + i__2 = j + k * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[ + i__2].i, z__1.i = alpha->r * a[i__2] + .i + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * + z__2.i, z__1.i = alpha->r * z__2.i + + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, z__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L290: */ - } - } + } + } /* L300: */ - } - temp.r = alpha->r, temp.i = alpha->i; - if (nounit) { - if (noconj) { - i__1 = k + k * a_dim1; - z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, - z__1.i = temp.r * a[i__1].i + temp.i * a[ - i__1].r; - temp.r = z__1.r, temp.i = z__1.i; - } else { - d_cnjg(&z__2, &a[k + k * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - } - if (temp.r != 1. || temp.i != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + k * b_dim1; - i__3 = i__ + k * b_dim1; - z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, - z__1.i = temp.r * b[i__3].i + temp.i * b[ - i__3].r; - b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__1 = k + k * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L310: */ - } - } + } + } /* L320: */ - } - } - } + } + } + } } return 0; @@ -758,5 +758,5 @@ extern "C" { } /* ztrmm_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/ztrmv.cpp b/lib/linalg/ztrmv.cpp index ffc55b16fe..77f93e41a6 100644 --- a/lib/linalg/ztrmv.cpp +++ b/lib/linalg/ztrmv.cpp @@ -1,13 +1,13 @@ /* fortran/ztrmv.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -160,9 +160,9 @@ extern "C" { /* > \endverbatim */ /* > */ /* ===================================================================== */ -/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n, - doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, - ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) +/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, + ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; @@ -212,31 +212,31 @@ extern "C" { /* Function Body */ info = 0; if (! lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, (char *)"L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - (char *)"N", (ftnlen)1, (ftnlen)1)) { - info = 3; + ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, (char *)"C", (ftnlen)1, ( + ftnlen)1)) { + info = 2; + } else if (! lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, + (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; } else if (*n < 0) { - info = 4; + info = 4; } else if (*lda < max(1,*n)) { - info = 6; + info = 6; } else if (*incx == 0) { - info = 8; + info = 8; } if (info != 0) { - xerbla_((char *)"ZTRMV ", &info, (ftnlen)6); - return 0; + xerbla_((char *)"ZTRMV ", &info, (ftnlen)6); + return 0; } /* Quick return if possible. */ if (*n == 0) { - return 0; + return 0; } noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); @@ -246,9 +246,9 @@ extern "C" { /* will be ( N - 1 )*INCX too small for descending loops. */ if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; + kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { - kx = 1; + kx = 1; } /* Start the operations. In this version the elements of A are */ @@ -258,359 +258,359 @@ extern "C" { /* Form x := A*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - z__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; /* L10: */ - } - if (nounit) { - i__2 = j; - i__3 = j; - i__4 = j + j * a_dim1; - z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ - i__4].i, z__1.i = x[i__3].r * a[i__4].i + - x[i__3].i * a[i__4].r; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - } + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, z__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } /* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = ix; - i__4 = ix; - i__5 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - z__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + - z__2.i; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - ix += *incx; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; /* L30: */ - } - if (nounit) { - i__2 = jx; - i__3 = jx; - i__4 = j + j * a_dim1; - z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ - i__4].i, z__1.i = x[i__3].r * a[i__4].i + - x[i__3].i * a[i__4].r; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - } - } - jx += *incx; + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, z__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; /* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - i__2 = i__; - i__3 = i__; - i__4 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - z__2.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* L50: */ - } - if (nounit) { - i__1 = j; - i__2 = j; - i__3 = j + j * a_dim1; - z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ - i__3].i, z__1.i = x[i__2].r * a[i__3].i + - x[i__2].i * a[i__3].r; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - } + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, z__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } /* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - i__2 = ix; - i__3 = ix; - i__4 = i__ + j * a_dim1; - z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - z__2.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - ix -= *incx; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; /* L70: */ - } - if (nounit) { - i__1 = jx; - i__2 = jx; - i__3 = j + j * a_dim1; - z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ - i__3].i, z__1.i = x[i__2].r * a[i__3].i + - x[i__2].i * a[i__3].r; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; - } - } - jx -= *incx; + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, z__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; /* L80: */ - } - } - } + } + } + } } else { /* Form x := A**T*x or x := A**H*x. */ - if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - if (noconj) { - if (nounit) { - i__1 = j + j * a_dim1; - z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, - z__1.i = temp.r * a[i__1].i + temp.i * a[ - i__1].r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - i__1 = i__ + j * a_dim1; - i__2 = i__; - z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, z__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__ + j * a_dim1; + i__2 = i__; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L90: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__1 = i__; - z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, - z__2.i = z__3.r * x[i__1].i + z__3.i * x[ - i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L100: */ - } - } - i__1 = j; - x[i__1].r = temp.r, x[i__1].i = temp.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; /* L110: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - i__1 = jx; - temp.r = x[i__1].r, temp.i = x[i__1].i; - ix = jx; - if (noconj) { - if (nounit) { - i__1 = j + j * a_dim1; - z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, - z__1.i = temp.r * a[i__1].i + temp.i * a[ - i__1].r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - i__1 = i__ + j * a_dim1; - i__2 = ix; - z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, z__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L120: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__1 = ix; - z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, - z__2.i = z__3.r * x[i__1].i + z__3.i * x[ - i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = ix; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L130: */ - } - } - i__1 = jx; - x[i__1].r = temp.r, x[i__1].i = temp.i; - jx -= *incx; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; /* L140: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - if (noconj) { - if (nounit) { - i__2 = j + j * a_dim1; - z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__1.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__; - z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ - i__4].i, z__2.i = a[i__3].r * x[i__4].i + - a[i__3].i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L150: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L160: */ - } - } - i__2 = j; - x[i__2].r = temp.r, x[i__2].i = temp.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; /* L170: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - temp.r = x[i__2].r, temp.i = x[i__2].i; - ix = jx; - if (noconj) { - if (nounit) { - i__2 = j + j * a_dim1; - z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__1.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - i__3 = i__ + j * a_dim1; - i__4 = ix; - z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ - i__4].i, z__2.i = a[i__3].r * x[i__4].i + - a[i__3].i * x[i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L180: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - d_cnjg(&z__3, &a[i__ + j * a_dim1]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, - z__2.i = z__3.r * x[i__3].i + z__3.i * x[ - i__3].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; /* L190: */ - } - } - i__2 = jx; - x[i__2].r = temp.r, x[i__2].i = temp.i; - jx += *incx; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; /* L200: */ - } - } - } + } + } + } } return 0; @@ -620,5 +620,5 @@ extern "C" { } /* ztrmv_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zung2l.cpp b/lib/linalg/zung2l.cpp index 45c03e5c78..4c4f96c5b0 100644 --- a/lib/linalg/zung2l.cpp +++ b/lib/linalg/zung2l.cpp @@ -1,13 +1,13 @@ /* fortran/zung2l.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -135,9 +135,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zung2l_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * - work, integer *info) +/* Subroutine */ int zung2l_(integer *m, integer *n, integer *k, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -145,11 +145,11 @@ f"> */ /* Local variables */ integer i__, j, l, ii; - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *), zlarf_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -185,70 +185,70 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNG2L", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNG2L", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } /* Initialise columns 1:n-k to columns of the unit matrix */ i__1 = *n - *k; for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - i__3 = l + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ - } - i__2 = *m - *n + j + j * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; + } + i__2 = *m - *n + j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; /* L20: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { - ii = *n - *k + i__; + ii = *n - *k + i__; /* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ - i__2 = *m - *n + ii + ii * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; - i__2 = *m - *n + ii; - i__3 = ii - 1; - zlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & - a[a_offset], lda, &work[1], (ftnlen)4); - i__2 = *m - *n + ii - 1; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zscal_(&i__2, &z__1, &a[ii * a_dim1 + 1], &c__1); - i__2 = *m - *n + ii + ii * a_dim1; - i__3 = i__; - z__1.r = 1. - tau[i__3].r, z__1.i = 0. - tau[i__3].i; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *m - *n + ii + ii * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - *n + ii; + i__3 = ii - 1; + zlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & + a[a_offset], lda, &work[1], (ftnlen)4); + i__2 = *m - *n + ii - 1; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zscal_(&i__2, &z__1, &a[ii * a_dim1 + 1], &c__1); + i__2 = *m - *n + ii + ii * a_dim1; + i__3 = i__; + z__1.r = 1. - tau[i__3].r, z__1.i = 0. - tau[i__3].i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* Set A(m-k+i+1:m,n-k+i) to zero */ - i__2 = *m; - for (l = *m - *n + ii + 1; l <= i__2; ++l) { - i__3 = l + ii * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + i__3 = l + ii * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -258,5 +258,5 @@ f"> */ } /* zung2l_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zung2r.cpp b/lib/linalg/zung2r.cpp index 4bd9202caa..044df4d2b0 100644 --- a/lib/linalg/zung2r.cpp +++ b/lib/linalg/zung2r.cpp @@ -1,13 +1,13 @@ /* fortran/zung2r.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -134,9 +134,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zung2r_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * - work, integer *info) +/* Subroutine */ int zung2r_(integer *m, integer *n, integer *k, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -144,11 +144,11 @@ f"> */ /* Local variables */ integer i__, j, l; - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *), zlarf_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, + ftnlen); /* -- LAPACK computational routine -- */ @@ -184,38 +184,38 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNG2R", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNG2R", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } /* Initialise columns k+1:n to columns of the unit matrix */ i__1 = *n; for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - i__3 = l + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ - } - i__2 = j + j * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; + } + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; /* L20: */ } @@ -223,34 +223,34 @@ f"> */ /* Apply H(i) to A(i:m,i:n) from the left */ - if (i__ < *n) { - i__1 = i__ + i__ * a_dim1; - a[i__1].r = 1., a[i__1].i = 0.; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - zlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( - ftnlen)4); - } - if (i__ < *m) { - i__1 = *m - i__; - i__2 = i__; - z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; - zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - } - i__1 = i__ + i__ * a_dim1; - i__2 = i__; - z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + if (i__ < *n) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + zlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], ( + ftnlen)4); + } + if (i__ < *m) { + i__1 = *m - i__; + i__2 = i__; + z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; + zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + i__1 = i__ + i__ * a_dim1; + i__2 = i__; + z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Set A(1:i-1,i) to zero */ - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - i__2 = l + i__ * a_dim1; - a[i__2].r = 0., a[i__2].i = 0.; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = l + i__ * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -260,5 +260,5 @@ f"> */ } /* zung2r_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zungl2.cpp b/lib/linalg/zungl2.cpp index bd40069fd6..d4b85486c6 100644 --- a/lib/linalg/zungl2.cpp +++ b/lib/linalg/zungl2.cpp @@ -1,13 +1,13 @@ /* fortran/zungl2.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -130,9 +130,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zungl2_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * - work, integer *info) +/* Subroutine */ int zungl2_(integer *m, integer *n, integer *k, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; @@ -143,11 +143,11 @@ f"> */ /* Local variables */ integer i__, j, l; - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *), zlarf_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, - ftnlen), zlacgv_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, + ftnlen), zlacgv_(integer *, doublecomplex *, integer *); /* -- LAPACK computational routine -- */ @@ -183,83 +183,83 @@ f"> */ /* Function Body */ *info = 0; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *m) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNGL2", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNGL2", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m <= 0) { - return 0; + return 0; } if (*k < *m) { /* Initialise rows k+1:m to rows of the unit matrix */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - i__3 = l + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ - } - if (j > *k && j <= *m) { - i__2 = j + j * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; - } + } + if (j > *k && j <= *m) { + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } /* L20: */ - } + } } for (i__ = *k; i__ >= 1; --i__) { /* Apply H(i)**H to A(i:m,i:n) from the right */ - if (i__ < *n) { - i__1 = *n - i__; - zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); - if (i__ < *m) { - i__1 = i__ + i__ * a_dim1; - a[i__1].r = 1., a[i__1].i = 0.; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - d_cnjg(&z__1, &tau[i__]); - zlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & - z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], ( - ftnlen)5); - } - i__1 = *n - i__; - i__2 = i__; - z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; - zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda); - i__1 = *n - i__; - zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); - } - i__1 = i__ + i__ * a_dim1; - d_cnjg(&z__2, &tau[i__]); - z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + if (i__ < *n) { + i__1 = *n - i__; + zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + if (i__ < *m) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + d_cnjg(&z__1, &tau[i__]); + zlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & + z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], ( + ftnlen)5); + } + i__1 = *n - i__; + i__2 = i__; + z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; + zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda); + i__1 = *n - i__; + zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + i__1 = i__ + i__ * a_dim1; + d_cnjg(&z__2, &tau[i__]); + z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Set A(i,1:i-1) to zero */ - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - i__2 = i__ + l * a_dim1; - a[i__2].r = 0., a[i__2].i = 0.; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = i__ + l * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ - } + } /* L40: */ } return 0; @@ -269,5 +269,5 @@ f"> */ } /* zungl2_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zungql.cpp b/lib/linalg/zungql.cpp index 006c4859eb..8ee03838d4 100644 --- a/lib/linalg/zungql.cpp +++ b/lib/linalg/zungql.cpp @@ -1,13 +1,13 @@ /* fortran/zungql.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -151,28 +151,28 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zungql_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * - work, integer *lwork, integer *info) +/* Subroutine */ int zungql_(integer *m, integer *n, integer *k, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; /* Local variables */ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int zung2l_(integer *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zung2l_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); integer ldwork; - extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen); logical lquery; integer lwkopt; @@ -213,42 +213,42 @@ f"> */ *info = 0; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } if (*info == 0) { - if (*n == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, ( - ftnlen)1); - lwkopt = *n * nb; - } - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, ( + ftnlen)1); + lwkopt = *n * nb; + } + work[1].r = (doublereal) lwkopt, work[1].i = 0.; - if (*lwork < max(1,*n) && ! lquery) { - *info = -8; - } + if (*lwork < max(1,*n) && ! lquery) { + *info = -8; + } } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNGQL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNGQL", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n <= 0) { - return 0; + return 0; } nbmin = 2; @@ -259,27 +259,27 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < *k && nx < *k) { @@ -288,23 +288,23 @@ f"> */ /* The last kk columns are handled by the block method. */ /* Computing MIN */ - i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; - kk = min(i__1,i__2); + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = min(i__1,i__2); /* Set A(m-kk+1:m,1:n-kk) to zero. */ - i__1 = *n - kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } + } } else { - kk = 0; + kk = 0; } /* Use unblocked code for the first or only block. */ @@ -313,60 +313,60 @@ f"> */ i__2 = *n - kk; i__3 = *k - kk; zung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) - ; + ; if (kk > 0) { /* Use blocked code */ - i__1 = *k; - i__2 = nb; - for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { /* Computing MIN */ - i__3 = nb, i__4 = *k - i__ + 1; - ib = min(i__3,i__4); - if (*n - *k + i__ > 1) { + i__3 = nb, i__4 = *k - i__ + 1; + ib = min(i__3,i__4); + if (*n - *k + i__ > 1) { /* Form the triangular factor of the block reflector */ /* H = H(i+ib-1) . . . H(i+1) H(i) */ - i__3 = *m - *k + i__ + ib - 1; - zlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + - i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork, - (ftnlen)8, (ftnlen)10); + i__3 = *m - *k + i__ + ib - 1; + zlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork, + (ftnlen)8, (ftnlen)10); /* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ - i__3 = *m - *k + i__ + ib - 1; - i__4 = *n - *k + i__ - 1; - zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", & - i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], - lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + - 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, ( - ftnlen)10); - } + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", & + i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], + lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, ( + ftnlen)10); + } /* Apply H to rows 1:m-k+i+ib-1 of current block */ - i__3 = *m - *k + i__ + ib - 1; - zung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & - tau[i__], &work[1], &iinfo); + i__3 = *m - *k + i__ + ib - 1; + zung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & + tau[i__], &work[1], &iinfo); /* Set rows m-k+i+ib:m of current block to zero */ - i__3 = *n - *k + i__ + ib - 1; - for (j = *n - *k + i__; j <= i__3; ++j) { - i__4 = *m; - for (l = *m - *k + i__ + ib; l <= i__4; ++l) { - i__5 = l + j * a_dim1; - a[i__5].r = 0., a[i__5].i = 0.; + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + i__5 = l + j * a_dim1; + a[i__5].r = 0., a[i__5].i = 0.; /* L30: */ - } + } /* L40: */ - } + } /* L50: */ - } + } } work[1].r = (doublereal) iws, work[1].i = 0.; @@ -377,5 +377,5 @@ f"> */ } /* zungql_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zungqr.cpp b/lib/linalg/zungqr.cpp index 7ce6a2a40d..a79c87eedd 100644 --- a/lib/linalg/zungqr.cpp +++ b/lib/linalg/zungqr.cpp @@ -1,13 +1,13 @@ /* fortran/zungqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -151,28 +151,28 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * - work, integer *lwork, integer *info) +/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); integer ldwork; - extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; @@ -216,29 +216,29 @@ f"> */ work[1].r = (doublereal) lwkopt, work[1].i = 0.; lquery = *lwork == -1; if (*m < 0) { - *info = -1; + *info = -1; } else if (*n < 0 || *n > *m) { - *info = -2; + *info = -2; } else if (*k < 0 || *k > *n) { - *info = -3; + *info = -3; } else if (*lda < max(1,*m)) { - *info = -5; + *info = -5; } else if (*lwork < max(1,*n) && ! lquery) { - *info = -8; + *info = -8; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNGQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNGQR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n <= 0) { - work[1].r = 1., work[1].i = 0.; - return 0; + work[1].r = 1., work[1].i = 0.; + return 0; } nbmin = 2; @@ -249,27 +249,27 @@ f"> */ /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = max(i__1,i__2); + if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ - nb = *lwork / ldwork; + nb = *lwork / ldwork; /* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = max(i__1,i__2); + } + } } if (nb >= nbmin && nb < *k && nx < *k) { @@ -277,87 +277,87 @@ f"> */ /* Use blocked code after the last block. */ /* The first kk columns are handled by the block method. */ - ki = (*k - nx - 1) / nb * nb; + ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); + i__1 = *k, i__2 = ki + nb; + kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ - } + } /* L20: */ - } + } } else { - kk = 0; + kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); } if (kk > 0) { /* Use blocked code */ - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *n) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2,i__3); + if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__2 = *m - i__ + 1; - zlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, - (ftnlen)10); + i__2 = *m - i__ + 1; + zlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, + (ftnlen)10); /* Apply H to A(i:m,i+ib:n) from the left */ - i__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", & - i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & - work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) - 7, (ftnlen)10); - } + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", & + i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & + work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) + 7, (ftnlen)10); + } /* Apply H to rows i:m of current block */ - i__2 = *m - i__ + 1; - zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); + i__2 = *m - i__ + 1; + zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); /* Set rows 1:i-1 of current block to zero */ - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - i__4 = l + j * a_dim1; - a[i__4].r = 0., a[i__4].i = 0.; + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + i__4 = l + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; /* L30: */ - } + } /* L40: */ - } + } /* L50: */ - } + } } work[1].r = (doublereal) iws, work[1].i = 0.; @@ -368,5 +368,5 @@ f"> */ } /* zungqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zungtr.cpp b/lib/linalg/zungtr.cpp index c8f42b6e21..86c03cb474 100644 --- a/lib/linalg/zungtr.cpp +++ b/lib/linalg/zungtr.cpp @@ -1,13 +1,13 @@ /* fortran/zungtr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -144,9 +144,9 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zungtr_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, - integer *info, ftnlen uplo_len) +/* Subroutine */ int zungtr_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, + integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; @@ -157,15 +157,15 @@ f"> */ integer iinfo; logical upper; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; - extern /* Subroutine */ int zungql_(integer *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, integer *), zungqr_(integer *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, integer *); + extern /* Subroutine */ int zungql_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zungqr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); /* -- LAPACK computational routine -- */ @@ -205,52 +205,52 @@ f"> */ lquery = *lwork == -1; upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (*n < 0) { - *info = -2; + *info = -2; } else if (*lda < max(1,*n)) { - *info = -4; + *info = -4; } else /* if(complicated condition) */ { /* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - if (*lwork < max(i__1,i__2) && ! lquery) { - *info = -7; - } + i__1 = 1, i__2 = *n - 1; + if (*lwork < max(i__1,i__2) && ! lquery) { + *info = -7; + } } if (*info == 0) { - if (upper) { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)1); - } else { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"ZUNGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)1); - } + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } /* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - lwkopt = max(i__1,i__2) * nb; - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + i__1 = 1, i__2 = *n - 1; + lwkopt = max(i__1,i__2) * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNGTR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNGTR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*n == 0) { - work[1].r = 1., work[1].i = 0.; - return 0; + work[1].r = 1., work[1].i = 0.; + return 0; } if (upper) { @@ -261,35 +261,35 @@ f"> */ /* column to the left, and set the last row and column of Q to */ /* those of the unit matrix */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * a_dim1; - i__4 = i__ + (j + 1) * a_dim1; - a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + (j + 1) * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; /* L10: */ - } - i__2 = *n + j * a_dim1; - a[i__2].r = 0., a[i__2].i = 0.; + } + i__2 = *n + j * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; /* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + *n * a_dim1; - a[i__2].r = 0., a[i__2].i = 0.; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + *n * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ - } - i__1 = *n + *n * a_dim1; - a[i__1].r = 1., a[i__1].i = 0.; + } + i__1 = *n + *n * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; /* Generate Q(1:n-1,1:n-1) */ - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - zungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], - lwork, &iinfo); + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + zungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], + lwork, &iinfo); } else { @@ -299,36 +299,36 @@ f"> */ /* column to the right, and set the first row and column of Q to */ /* those of the unit matrix */ - for (j = *n; j >= 2; --j) { - i__1 = j * a_dim1 + 1; - a[i__1].r = 0., a[i__1].i = 0.; - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - i__2 = i__ + j * a_dim1; - i__3 = i__ + (j - 1) * a_dim1; - a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + for (j = *n; j >= 2; --j) { + i__1 = j * a_dim1 + 1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__ + (j - 1) * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; /* L40: */ - } + } /* L50: */ - } - i__1 = a_dim1 + 1; - a[i__1].r = 1., a[i__1].i = 0.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - i__2 = i__ + a_dim1; - a[i__2].r = 0., a[i__2].i = 0.; + } + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; /* L60: */ - } - if (*n > 1) { + } + if (*n > 1) { /* Generate Q(2:n,2:n) */ - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], - &work[1], lwork, &iinfo); - } + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], + &work[1], lwork, &iinfo); + } } work[1].r = (doublereal) lwkopt, work[1].i = 0.; return 0; @@ -338,5 +338,5 @@ f"> */ } /* zungtr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zunm2l.cpp b/lib/linalg/zunm2l.cpp index d7fc940517..d9bc80e8c7 100644 --- a/lib/linalg/zunm2l.cpp +++ b/lib/linalg/zunm2l.cpp @@ -1,13 +1,13 @@ /* fortran/zunm2l.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by +/* > \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm). */ /* =========== DOCUMENTATION =========== */ @@ -179,10 +179,10 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zunm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info, - ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int zunm2l_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info, + ftnlen side_len, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; @@ -197,10 +197,10 @@ f"> */ logical left; doublecomplex taui; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarf_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, + ftnlen); logical notran; @@ -247,85 +247,85 @@ f"> */ /* NQ is the order of Q */ if (left) { - nq = *m; + nq = *m; } else { - nq = *n; + nq = *n; } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNM2L", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNM2L", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - return 0; + return 0; } if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; + i1 = 1; + i2 = *k; + i3 = 1; } else { - i1 = *k; - i2 = 1; - i3 = -1; + i1 = *k; + i2 = 1; + i3 = -1; } if (left) { - ni = *n; + ni = *n; } else { - mi = *m; + mi = *m; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { + if (left) { /* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) */ - mi = *m - *k + i__; - } else { + mi = *m - *k + i__; + } else { /* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) */ - ni = *n - *k + i__; - } + ni = *n - *k + i__; + } /* Apply H(i) or H(i)**H */ - if (notran) { - i__3 = i__; - taui.r = tau[i__3].r, taui.i = tau[i__3].i; - } else { - d_cnjg(&z__1, &tau[i__]); - taui.r = z__1.r, taui.i = z__1.i; - } - i__3 = nq - *k + i__ + i__ * a_dim1; - aii.r = a[i__3].r, aii.i = a[i__3].i; - i__3 = nq - *k + i__ + i__ * a_dim1; - a[i__3].r = 1., a[i__3].i = 0.; - zlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[ - c_offset], ldc, &work[1], (ftnlen)1); - i__3 = nq - *k + i__ + i__ * a_dim1; - a[i__3].r = aii.r, a[i__3].i = aii.i; + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + d_cnjg(&z__1, &tau[i__]); + taui.r = z__1.r, taui.i = z__1.i; + } + i__3 = nq - *k + i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + zlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[ + c_offset], ldc, &work[1], (ftnlen)1); + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; /* L10: */ } return 0; @@ -335,5 +335,5 @@ f"> */ } /* zunm2l_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zunm2r.cpp b/lib/linalg/zunm2r.cpp index 56ad0d944a..a84cf72ba6 100644 --- a/lib/linalg/zunm2r.cpp +++ b/lib/linalg/zunm2r.cpp @@ -1,13 +1,13 @@ /* fortran/zunm2r.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -19,7 +19,7 @@ extern "C" { static integer c__1 = 1; -/* > \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by +/* > \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). */ /* =========== DOCUMENTATION =========== */ @@ -179,10 +179,10 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info, - ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info, + ftnlen side_len, ftnlen trans_len) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; @@ -197,10 +197,10 @@ f"> */ logical left; doublecomplex taui; extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarf_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, - ftnlen); + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *, + ftnlen); logical notran; @@ -247,89 +247,89 @@ f"> */ /* NQ is the order of Q */ if (left) { - nq = *m; + nq = *m; } else { - nq = *n; + nq = *n; } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNM2R", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNM2R", &i__1, (ftnlen)6); + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - return 0; + return 0; } if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; + i1 = 1; + i2 = *k; + i3 = 1; } else { - i1 = *k; - i2 = 1; - i3 = -1; + i1 = *k; + i2 = 1; + i3 = -1; } if (left) { - ni = *n; - jc = 1; + ni = *n; + jc = 1; } else { - mi = *m; - ic = 1; + mi = *m; + ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { + if (left) { /* H(i) or H(i)**H is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H(i) or H(i)**H is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H(i) or H(i)**H */ - if (notran) { - i__3 = i__; - taui.r = tau[i__3].r, taui.i = tau[i__3].i; - } else { - d_cnjg(&z__1, &tau[i__]); - taui.r = z__1.r, taui.i = z__1.i; - } - i__3 = i__ + i__ * a_dim1; - aii.r = a[i__3].r, aii.i = a[i__3].i; - i__3 = i__ + i__ * a_dim1; - a[i__3].r = 1., a[i__3].i = 0.; - zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic - + jc * c_dim1], ldc, &work[1], (ftnlen)1); - i__3 = i__ + i__ * a_dim1; - a[i__3].r = aii.r, a[i__3].i = aii.i; + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + d_cnjg(&z__1, &tau[i__]); + taui.r = z__1.r, taui.i = z__1.i; + } + i__3 = i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = i__ + i__ * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic + + jc * c_dim1], ldc, &work[1], (ftnlen)1); + i__3 = i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; /* L10: */ } return 0; @@ -339,5 +339,5 @@ f"> */ } /* zunm2r_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zunmql.cpp b/lib/linalg/zunmql.cpp index c7e6134831..facff63c71 100644 --- a/lib/linalg/zunmql.cpp +++ b/lib/linalg/zunmql.cpp @@ -1,13 +1,13 @@ /* fortran/zunmql.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,15 +189,15 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zunmql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, - integer *info, ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int zunmql_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, + integer *info, ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; char ch__1[2]; /* Builtin functions */ @@ -208,21 +208,21 @@ f"> */ logical left; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; - extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical notran; integer ldwork; - extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; @@ -271,141 +271,141 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { /* Compute the workspace requirements */ - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { /* Computing MIN */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, - (ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = nw * nb + 4160; - } - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = min(i__1,i__2); + lwkopt = nw * nb + 4160; + } + work[1].r = (doublereal) lwkopt, work[1].i = 0.; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNMQL", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNMQL", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { - return 0; + return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { - if (*lwork < lwkopt) { - nb = (*lwork - 4160) / ldwork; + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; /* Computing MAX */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = max(i__1,i__2); + } } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ - zunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); + zunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - iwt = nw * nb + 1; - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } + iwt = nw * nb + 1; + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } - if (left) { - ni = *n; - } else { - mi = *m; - } + if (left) { + ni = *n; + } else { + mi = *m; + } - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i+ib-1) . . . H(i+1) H(i) */ - i__4 = nq - *k + i__ + ib - 1; - zlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] - , lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen) - 10); - if (left) { + i__4 = nq - *k + i__ + ib - 1; + zlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] + , lda, &tau[i__], &work[iwt], &c__65, (ftnlen)8, (ftnlen) + 10); + if (left) { /* H or H**H is applied to C(1:m-k+i+ib-1,1:n) */ - mi = *m - *k + i__ + ib - 1; - } else { + mi = *m - *k + i__ + ib - 1; + } else { /* H or H**H is applied to C(1:m,1:n-k+i+ib-1) */ - ni = *n - *k + i__ + ib - 1; - } + ni = *n - *k + i__ + ib - 1; + } /* Apply H or H**H */ - zlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[ - i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] - , ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8, - (ftnlen)10); + zlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[ + i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] + , ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen)1, (ftnlen)8, + (ftnlen)10); /* L10: */ - } + } } work[1].r = (doublereal) lwkopt, work[1].i = 0.; return 0; @@ -415,5 +415,5 @@ f"> */ } /* zunmql_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zunmqr.cpp b/lib/linalg/zunmqr.cpp index dc127fe1aa..8659499dab 100644 --- a/lib/linalg/zunmqr.cpp +++ b/lib/linalg/zunmqr.cpp @@ -1,13 +1,13 @@ /* fortran/zunmqr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -189,15 +189,15 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zunmqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, - integer *info, ftnlen side_len, ftnlen trans_len) +/* Subroutine */ int zunmqr_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, + integer *info, ftnlen side_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; char ch__1[2]; /* Builtin functions */ @@ -208,21 +208,21 @@ f"> */ logical left; extern logical lsame_(char *, char *, ftnlen, ftnlen); integer nbmin, iinfo; - extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, + ftnlen), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); logical notran; integer ldwork; - extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; @@ -271,28 +271,28 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! notran && ! lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -2; + *info = -2; } else if (*m < 0) { - *info = -3; + *info = -3; } else if (*n < 0) { - *info = -4; + *info = -4; } else if (*k < 0 || *k > nq) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { @@ -301,112 +301,112 @@ f"> */ /* Computing MIN */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = nw * nb + 4160; - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nb = min(i__1,i__2); + lwkopt = nw * nb + 4160; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; } if (*info != 0) { - i__1 = -(*info); - xerbla_((char *)"ZUNMQR", &i__1, (ftnlen)6); - return 0; + i__1 = -(*info); + xerbla_((char *)"ZUNMQR", &i__1, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { - work[1].r = 1., work[1].i = 0.; - return 0; + work[1].r = 1., work[1].i = 0.; + return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { - if (*lwork < lwkopt) { - nb = (*lwork - 4160) / ldwork; + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; /* Computing MAX */ /* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = max(i__1,i__2); + } } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ - zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); + zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo, (ftnlen)1, (ftnlen)1); } else { /* Use blocked code */ - iwt = nw * nb + 1; - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } + iwt = nw * nb + 1; + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ - i__4 = nq - i__ + 1; - zlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, ( - ftnlen)10); - if (left) { + i__4 = nq - i__ + 1; + zlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[iwt], &c__65, (ftnlen)7, ( + ftnlen)10); + if (left) { /* H or H**H is applied to C(i:m,1:n) */ - mi = *m - i__ + 1; - ic = i__; - } else { + mi = *m - i__ + 1; + ic = i__; + } else { /* H or H**H is applied to C(1:m,i:n) */ - ni = *n - i__ + 1; - jc = i__; - } + ni = *n - i__ + 1; + jc = i__; + } /* Apply H or H**H */ - zlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[ - i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + - jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen) - 1, (ftnlen)7, (ftnlen)10); + zlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[ + i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + + jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, (ftnlen) + 1, (ftnlen)7, (ftnlen)10); /* L10: */ - } + } } work[1].r = (doublereal) lwkopt, work[1].i = 0.; return 0; @@ -416,5 +416,5 @@ f"> */ } /* zunmqr_ */ #ifdef __cplusplus - } + } #endif diff --git a/lib/linalg/zunmtr.cpp b/lib/linalg/zunmtr.cpp index ab5e7eacb8..be224d7e93 100644 --- a/lib/linalg/zunmtr.cpp +++ b/lib/linalg/zunmtr.cpp @@ -1,13 +1,13 @@ /* fortran/zunmtr.f -- translated by f2c (version 20200916). You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - http://www.netlib.org/f2c/libf2c.zip + http://www.netlib.org/f2c/libf2c.zip */ #ifdef __cplusplus @@ -192,10 +192,10 @@ f"> */ /* > \ingroup complex16OTHERcomputational */ /* ===================================================================== */ -/* Subroutine */ int zunmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, - integer *info, ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) +/* Subroutine */ int zunmtr_(char *side, char *uplo, char *trans, integer *m, + integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, + integer *info, ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) { /* System generated locals */ address a__1[2]; @@ -212,17 +212,17 @@ f"> */ integer iinfo; logical upper; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; - extern /* Subroutine */ int zunmql_(char *, char *, integer *, integer *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, integer *, - ftnlen, ftnlen), zunmqr_(char *, char *, integer *, integer *, - integer *, doublecomplex *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, integer *, - ftnlen, ftnlen); + extern /* Subroutine */ int zunmql_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *, + ftnlen, ftnlen), zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *, + ftnlen, ftnlen); /* -- LAPACK computational routine -- */ @@ -267,123 +267,123 @@ f"> */ /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { - nq = *m; - nw = max(1,*n); + nq = *m; + nw = max(1,*n); } else { - nq = *n; - nw = max(1,*m); + nq = *n; + nw = max(1,*m); } if (! left && ! lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { - *info = -1; + *info = -1; } else if (! upper && ! lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { - *info = -2; - } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - (char *)"C", (ftnlen)1, (ftnlen)1)) { - *info = -3; + *info = -2; + } else if (! lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, + (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -3; } else if (*m < 0) { - *info = -4; + *info = -4; } else if (*n < 0) { - *info = -5; + *info = -5; } else if (*lda < max(1,nq)) { - *info = -7; + *info = -7; } else if (*ldc < max(1,*m)) { - *info = -10; + *info = -10; } else if (*lwork < nw && ! lquery) { - *info = -12; + *info = -12; } if (*info == 0) { - if (upper) { - if (left) { + if (upper) { + if (left) { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, &i__2, n, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } else { - if (left) { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } else { + if (left) { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, &i__2, n, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { /* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, &i__2, &i__3, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } - lwkopt = nw * nb; - work[1].r = (doublereal) lwkopt, work[1].i = 0.; + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; } if (*info != 0) { - i__2 = -(*info); - xerbla_((char *)"ZUNMTR", &i__2, (ftnlen)6); - return 0; + i__2 = -(*info); + xerbla_((char *)"ZUNMTR", &i__2, (ftnlen)6); + return 0; } else if (lquery) { - return 0; + return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || nq == 1) { - work[1].r = 1., work[1].i = 0.; - return 0; + work[1].r = 1., work[1].i = 0.; + return 0; } if (left) { - mi = *m - 1; - ni = *n; + mi = *m - 1; + ni = *n; } else { - mi = *m; - ni = *n - 1; + mi = *m; + ni = *n - 1; } if (upper) { /* Q was determined by a call to ZHETRD with UPLO = 'U' */ - i__2 = nq - 1; - zunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & - tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen) - 1, (ftnlen)1); + i__2 = nq - 1; + zunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & + tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen) + 1, (ftnlen)1); } else { /* Q was determined by a call to ZHETRD with UPLO = 'L' */ - if (left) { - i1 = 2; - i2 = 1; - } else { - i1 = 1; - i2 = 2; - } - i__2 = nq - 1; - zunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & - c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen) - 1, (ftnlen)1); + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + zunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & + c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen) + 1, (ftnlen)1); } work[1].r = (doublereal) lwkopt, work[1].i = 0.; return 0; @@ -393,5 +393,5 @@ f"> */ } /* zunmtr_ */ #ifdef __cplusplus - } + } #endif