diff --git a/lapack-netlib/SRC/cgedmd.f90 b/lapack-netlib/SRC/cgedmd.f90 index 1413130ec3..aba81fb731 100644 --- a/lapack-netlib/SRC/cgedmd.f90 +++ b/lapack-netlib/SRC/cgedmd.f90 @@ -1,1151 +1,1154 @@ -!> \brief \b CGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. -! -! =========== DOCUMENTATION =========== -! -! Definition: -! =========== -! -! SUBROUTINE CGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & -! M, N, X, LDX, Y, LDY, NRNK, TOL, & -! K, EIGS, Z, LDZ, RES, B, LDB, & -! W, LDW, S, LDS, ZWORK, LZWORK, & -! RWORK, LRWORK, IWORK, LIWORK, INFO ) -!..... -! USE iso_fortran_env -! IMPLICIT NONE -! INTEGER, PARAMETER :: WP = real32 -! -!..... -! Scalar arguments -! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF -! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & -! NRNK, LDZ, LDB, LDW, LDS, & -! LIWORK, LRWORK, LZWORK -! INTEGER, INTENT(OUT) :: K, INFO -! REAL(KIND=WP), INTENT(IN) :: TOL -! Array arguments -! COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) -! COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & -! W(LDW,*), S(LDS,*) -! COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) -! COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) -! REAL(KIND=WP), INTENT(OUT) :: RES(*) -! REAL(KIND=WP), INTENT(OUT) :: RWORK(*) -! INTEGER, INTENT(OUT) :: IWORK(*) -! -!............................................................ -!> \par Purpose: -! ============= -!> \verbatim -!> CGEDMD computes the Dynamic Mode Decomposition (DMD) for -!> a pair of data snapshot matrices. For the input matrices -!> X and Y such that Y = A*X with an unaccessible matrix -!> A, CGEDMD computes a certain number of Ritz pairs of A using -!> the standard Rayleigh-Ritz extraction from a subspace of -!> range(X) that is determined using the leading left singular -!> vectors of X. Optionally, CGEDMD returns the residuals -!> of the computed Ritz pairs, the information needed for -!> a refinement of the Ritz vectors, or the eigenvectors of -!> the Exact DMD. -!> For further details see the references listed -!> below. For more details of the implementation see [3]. -!> \endverbatim -!............................................................ -!> \par References: -! ================ -!> \verbatim -!> [1] P. Schmid: Dynamic mode decomposition of numerical -!> and experimental data, -!> Journal of Fluid Mechanics 656, 5-28, 2010. -!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal -!> decompositions: analysis and enhancements, -!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. -!> [3] Z. Drmac: A LAPACK implementation of the Dynamic -!> Mode Decomposition I. Technical report. AIMDyn Inc. -!> and LAPACK Working Note 298. -!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. -!> Brunton, N. Kutz: On Dynamic Mode Decomposition: -!> Theory and Applications, Journal of Computational -!> Dynamics 1(2), 391 -421, 2014. -!> \endverbatim -!...................................................................... -!> \par Developed and supported by: -! ================================ -!> \verbatim -!> Developed and coded by Zlatko Drmac, Faculty of Science, -!> University of Zagreb; drmac@math.hr -!> In cooperation with -!> AIMdyn Inc., Santa Barbara, CA. -!> and supported by -!> - DARPA SBIR project "Koopman Operator-Based Forecasting -!> for Nonstationary Processes from Near-Term, Limited -!> Observational Data" Contract No: W31P4Q-21-C-0007 -!> - DARPA PAI project "Physics-Informed Machine Learning -!> Methodologies" Contract No: HR0011-18-9-0033 -!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic -!> Framework for Space-Time Analysis of Process Dynamics" -!> Contract No: HR0011-16-C-0116 -!> Any opinions, findings and conclusions or recommendations -!> expressed in this material are those of the author and -!> do not necessarily reflect the views of the DARPA SBIR -!> Program Office -!> \endverbatim -!...................................................................... -!> \par Distribution Statement A: -! ============================== -!> \verbatim -!> Approved for Public Release, Distribution Unlimited. -!> Cleared by DARPA on September 29, 2022 -!> \endverbatim -!...................................................................... -! Arguments -! ========= -! -!> \param[in] JOBS -!> \verbatim -!> JOBS (input) CHARACTER*1 -!> Determines whether the initial data snapshots are scaled -!> by a diagonal matrix. -!> 'S' :: The data snapshots matrices X and Y are multiplied -!> with a diagonal matrix D so that X*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'C' :: The snapshots are scaled as with the 'S' option. -!> If it is found that an i-th column of X is zero -!> vector and the corresponding i-th column of Y is -!> non-zero, then the i-th column of Y is set to -!> zero and a warning flag is raised. -!> 'Y' :: The data snapshots matrices X and Y are multiplied -!> by a diagonal matrix D so that Y*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'N' :: No data scaling. -!> \endverbatim -!..... -!> \param[in] JOBZ -!> \verbatim -!> JOBZ (input) CHARACTER*1 -!> Determines whether the eigenvectors (Koopman modes) will -!> be computed. -!> 'V' :: The eigenvectors (Koopman modes) will be computed -!> and returned in the matrix Z. -!> See the description of Z. -!> 'F' :: The eigenvectors (Koopman modes) will be returned -!> in factored form as the product X(:,1:K)*W, where X -!> contains a POD basis (leading left singular vectors -!> of the data matrix X) and W contains the eigenvectors -!> of the corresponding Rayleigh quotient. -!> See the descriptions of K, X, W, Z. -!> 'N' :: The eigenvectors are not computed. -!> \endverbatim -!..... -!> \param[in] JOBR -!> \verbatim -!> JOBR (input) CHARACTER*1 -!> Determines whether to compute the residuals. -!> 'R' :: The residuals for the computed eigenpairs will be -!> computed and stored in the array RES. -!> See the description of RES. -!> For this option to be legal, JOBZ must be 'V'. -!> 'N' :: The residuals are not computed. -!> \endverbatim -!..... -!> \param[in] JOBF -!> \verbatim -!> JOBF (input) CHARACTER*1 -!> Specifies whether to store information needed for post- -!> processing (e.g. computing refined Ritz vectors) -!> 'R' :: The matrix needed for the refinement of the Ritz -!> vectors is computed and stored in the array B. -!> See the description of B. -!> 'E' :: The unscaled eigenvectors of the Exact DMD are -!> computed and returned in the array B. See the -!> description of B. -!> 'N' :: No eigenvector refinement data is computed. -!> \endverbatim -!..... -!> \param[in] WHTSVD -!> \verbatim -!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } -!> Allows for a selection of the SVD algorithm from the -!> LAPACK library. -!> 1 :: CGESVD (the QR SVD algorithm) -!> 2 :: CGESDD (the Divide and Conquer algorithm; if enough -!> workspace available, this is the fastest option) -!> 3 :: CGESVDQ (the preconditioned QR SVD ; this and 4 -!> are the most accurate options) -!> 4 :: CGEJSV (the preconditioned Jacobi SVD; this and 3 -!> are the most accurate options) -!> For the four methods above, a significant difference in -!> the accuracy of small singular values is possible if -!> the snapshots vary in norm so that X is severely -!> ill-conditioned. If small (smaller than EPS*||X||) -!> singular values are of interest and JOBS=='N', then -!> the options (3, 4) give the most accurate results, where -!> the option 4 is slightly better and with stronger -!> theoretical background. -!> If JOBS=='S', i.e. the columns of X will be normalized, -!> then all methods give nearly equally accurate results. -!> \endverbatim -!..... -!> \param[in] M -!> \verbatim -!> M (input) INTEGER, M>= 0 -!> The state space dimension (the row dimension of X, Y). -!> \endverbatim -!..... -!> \param[in] N -!> \verbatim -!> N (input) INTEGER, 0 <= N <= M -!> The number of data snapshot pairs -!> (the number of columns of X and Y). -!> \endverbatim -!..... -!> \param[in,out] X -!> \verbatim -!> X (input/output) COMPLEX(KIND=WP) M-by-N array -!> > On entry, X contains the data snapshot matrix X. It is -!> assumed that the column norms of X are in the range of -!> the normalized floating point numbers. -!> < On exit, the leading K columns of X contain a POD basis, -!> i.e. the leading K left singular vectors of the input -!> data matrix X, U(:,1:K). All N columns of X contain all -!> left singular vectors of the input matrix X. -!> See the descriptions of K, Z and W. -!> \endverbatim -!..... -!> \param[in] LDX -!> \verbatim -!> LDX (input) INTEGER, LDX >= M -!> The leading dimension of the array X. -!> \endverbatim -!..... -!> \param[in,out] Y -!> \verbatim -!> Y (input/workspace/output) COMPLEX(KIND=WP) M-by-N array -!> > On entry, Y contains the data snapshot matrix Y -!> < On exit, -!> If JOBR == 'R', the leading K columns of Y contain -!> the residual vectors for the computed Ritz pairs. -!> See the description of RES. -!> If JOBR == 'N', Y contains the original input data, -!> scaled according to the value of JOBS. -!> \endverbatim -!..... -!> \param[in] LDY -!> \verbatim -!> LDY (input) INTEGER , LDY >= M -!> The leading dimension of the array Y. -!> \endverbatim -!..... -!> \param[in] NRNK -!> \verbatim -!> NRNK (input) INTEGER -!> Determines the mode how to compute the numerical rank, -!> i.e. how to truncate small singular values of the input -!> matrix X. On input, if -!> NRNK = -1 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(1) -!> This option is recommended. -!> NRNK = -2 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(i-1) -!> This option is included for R&D purposes. -!> It requires highly accurate SVD, which -!> may not be feasible. -!> The numerical rank can be enforced by using positive -!> value of NRNK as follows: -!> 0 < NRNK <= N :: at most NRNK largest singular values -!> will be used. If the number of the computed nonzero -!> singular values is less than NRNK, then only those -!> nonzero values will be used and the actually used -!> dimension is less than NRNK. The actual number of -!> the nonzero singular values is returned in the variable -!> K. See the descriptions of TOL and K. -!> \endverbatim -!..... -!> \param[in] TOL -!> \verbatim -!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 -!> The tolerance for truncating small singular values. -!> See the description of NRNK. -!> \endverbatim -!..... -!> \param[out] K -!> \verbatim -!> K (output) INTEGER, 0 <= K <= N -!> The dimension of the POD basis for the data snapshot -!> matrix X and the number of the computed Ritz pairs. -!> The value of K is determined according to the rule set -!> by the parameters NRNK and TOL. -!> See the descriptions of NRNK and TOL. -!> \endverbatim -!..... -!> \param[out] EIGS -!> \verbatim -!> EIGS (output) COMPLEX(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of EIGS contain -!> the computed eigenvalues (Ritz values). -!> See the descriptions of K, and Z. -!> \endverbatim -!..... -!> \param[out] Z -!> \verbatim -!> Z (workspace/output) COMPLEX(KIND=WP) M-by-N array -!> If JOBZ =='V' then Z contains the Ritz vectors. Z(:,i) -!> is an eigenvector of the i-th Ritz value; ||Z(:,i)||_2=1. -!> If JOBZ == 'F', then the Z(:,i)'s are given implicitly as -!> the columns of X(:,1:K)*W(1:K,1:K), i.e. X(:,1:K)*W(:,i) -!> is an eigenvector corresponding to EIGS(i). The columns -!> of W(1:k,1:K) are the computed eigenvectors of the -!> K-by-K Rayleigh quotient. -!> See the descriptions of EIGS, X and W. -!> \endverbatim -!..... -!> \param[in] LDZ -!> \verbatim -!> LDZ (input) INTEGER , LDZ >= M -!> The leading dimension of the array Z. -!> \endverbatim -!..... -!> \param[out] RES -!> \verbatim -!> RES (output) REAL(KIND=WP) N-by-1 array -!> RES(1:K) contains the residuals for the K computed -!> Ritz pairs, -!> RES(i) = || A * Z(:,i) - EIGS(i)*Z(:,i))||_2. -!> See the description of EIGS and Z. -!> \endverbatim -!..... -!> \param[out] B -!> \verbatim -!> B (output) COMPLEX(KIND=WP) M-by-N array. -!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can -!> be used for computing the refined vectors; see further -!> details in the provided references. -!> If JOBF == 'E', B(1:M,1:K) contains -!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the -!> Exact DMD, up to scaling by the inverse eigenvalues. -!> If JOBF =='N', then B is not referenced. -!> See the descriptions of X, W, K. -!> \endverbatim -!..... -!> \param[in] LDB -!> \verbatim -!> LDB (input) INTEGER, LDB >= M -!> The leading dimension of the array B. -!> \endverbatim -!..... -!> \param[out] W -!> \verbatim -!> W (workspace/output) COMPLEX(KIND=WP) N-by-N array -!> On exit, W(1:K,1:K) contains the K computed -!> eigenvectors of the matrix Rayleigh quotient. -!> The Ritz vectors (returned in Z) are the -!> product of X (containing a POD basis for the input -!> matrix X) and W. See the descriptions of K, S, X and Z. -!> W is also used as a workspace to temporarily store the -!> right singular vectors of X. -!> \endverbatim -!..... -!> \param[in] LDW -!> \verbatim -!> LDW (input) INTEGER, LDW >= N -!> The leading dimension of the array W. -!> \endverbatim -!..... -!> \param[out] S -!> \verbatim -!> S (workspace/output) COMPLEX(KIND=WP) N-by-N array -!> The array S(1:K,1:K) is used for the matrix Rayleigh -!> quotient. This content is overwritten during -!> the eigenvalue decomposition by CGEEV. -!> See the description of K. -!> \endverbatim -!..... -!> \param[in] LDS -!> \verbatim -!> LDS (input) INTEGER, LDS >= N -!> The leading dimension of the array S. -!> \endverbatim -!..... -!> \param[out] ZWORK -!> \verbatim -!> ZWORK (workspace/output) COMPLEX(KIND=WP) LZWORK-by-1 array -!> ZWORK is used as complex workspace in the complex SVD, as -!> specified by WHTSVD (1,2, 3 or 4) and for CGEEV for computing -!> the eigenvalues of a Rayleigh quotient. -!> If the call to CGEDMD is only workspace query, then -!> ZWORK(1) contains the minimal complex workspace length and -!> ZWORK(2) is the optimal complex workspace length. -!> Hence, the length of work is at least 2. -!> See the description of LZWORK. -!> \endverbatim -!..... -!> \param[in] LZWORK -!> \verbatim -!> LZWORK (input) INTEGER -!> The minimal length of the workspace vector ZWORK. -!> LZWORK is calculated as MAX(LZWORK_SVD, LZWORK_CGEEV), -!> where LZWORK_CGEEV = MAX( 1, 2*N ) and the minimal -!> LZWORK_SVD is calculated as follows -!> If WHTSVD == 1 :: CGESVD :: -!> LZWORK_SVD = MAX(1,2*MIN(M,N)+MAX(M,N)) -!> If WHTSVD == 2 :: CGESDD :: -!> LZWORK_SVD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) -!> If WHTSVD == 3 :: CGESVDQ :: -!> LZWORK_SVD = obtainable by a query -!> If WHTSVD == 4 :: CGEJSV :: -!> LZWORK_SVD = obtainable by a query -!> If on entry LZWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths and returns them in -!> LZWORK(1) and LZWORK(2), respectively. -!> \endverbatim -!..... -!> \param[out] RWORK -!> \verbatim -!> RWORK (workspace/output) REAL(KIND=WP) LRWORK-by-1 array -!> On exit, RWORK(1:N) contains the singular values of -!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). -!> If WHTSVD==4, then RWORK(N+1) and RWORK(N+2) contain -!> scaling factor RWORK(N+2)/RWORK(N+1) used to scale X -!> and Y to avoid overflow in the SVD of X. -!> This may be of interest if the scaling option is off -!> and as many as possible smallest eigenvalues are -!> desired to the highest feasible accuracy. -!> If the call to CGEDMD is only workspace query, then -!> RWORK(1) contains the minimal workspace length. -!> See the description of LRWORK. -!> \endverbatim -!..... -!> \param[in] LRWORK -!> \verbatim -!> LRWORK (input) INTEGER -!> The minimal length of the workspace vector RWORK. -!> LRWORK is calculated as follows: -!> LRWORK = MAX(1, N+LRWORK_SVD,N+LRWORK_CGEEV), where -!> LRWORK_CGEEV = MAX(1,2*N) and RWORK_SVD is the real workspace -!> for the SVD subroutine determined by the input parameter -!> WHTSVD. -!> If WHTSVD == 1 :: CGESVD :: -!> LRWORK_SVD = 5*MIN(M,N) -!> If WHTSVD == 2 :: CGESDD :: -!> LRWORK_SVD = MAX(5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), -!> 2*MAX(M,N)*MIN(M,N)+2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) -!> If WHTSVD == 3 :: CGESVDQ :: -!> LRWORK_SVD = obtainable by a query -!> If WHTSVD == 4 :: CGEJSV :: -!> LRWORK_SVD = obtainable by a query -!> If on entry LRWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> real workspace length and returns it in RWORK(1). -!> \endverbatim -!..... -!> \param[out] IWORK -!> \verbatim -!> IWORK (workspace/output) INTEGER LIWORK-by-1 array -!> Workspace that is required only if WHTSVD equals -!> 2 , 3 or 4. (See the description of WHTSVD). -!> If on entry LWORK =-1 or LIWORK=-1, then the -!> minimal length of IWORK is computed and returned in -!> IWORK(1). See the description of LIWORK. -!> \endverbatim -!..... -!> \param[in] LIWORK -!> \verbatim -!> LIWORK (input) INTEGER -!> The minimal length of the workspace vector IWORK. -!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 -!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) -!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) -!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) -!> If on entry LIWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for ZWORK, RWORK and -!> IWORK. See the descriptions of ZWORK, RWORK and IWORK. -!> \endverbatim -!..... -!> \param[out] INFO -!> \verbatim -!> INFO (output) INTEGER -!> -i < 0 :: On entry, the i-th argument had an -!> illegal value -!> = 0 :: Successful return. -!> = 1 :: Void input. Quick exit (M=0 or N=0). -!> = 2 :: The SVD computation of X did not converge. -!> Suggestion: Check the input data and/or -!> repeat with different WHTSVD. -!> = 3 :: The computation of the eigenvalues did not -!> converge. -!> = 4 :: If data scaling was requested on input and -!> the procedure found inconsistency in the data -!> such that for some column index i, -!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set -!> to zero if JOBS=='C'. The computation proceeds -!> with original or modified data and warning -!> flag is set with INFO=4. -!> \endverbatim -! -! Authors: -! ======== -! -!> \author Zlatko Drmac -! -!> \ingroup gedmd -! -!............................................................. -!............................................................. - SUBROUTINE CGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & - M, N, X, LDX, Y, LDY, NRNK, TOL, & - K, EIGS, Z, LDZ, RES, B, LDB, & - W, LDW, S, LDS, ZWORK, LZWORK, & - RWORK, LRWORK, IWORK, LIWORK, INFO ) -! -! -- LAPACK driver routine -- -! -! -- LAPACK is a software package provided by University of -- -! -- Tennessee, University of California Berkeley, University of -- -! -- Colorado Denver and NAG Ltd.. -- -! -!..... - USE iso_fortran_env - IMPLICIT NONE - INTEGER, PARAMETER :: WP = real32 -! -! Scalar arguments -! ~~~~~~~~~~~~~~~~ - CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF - INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & - NRNK, LDZ, LDB, LDW, LDS, & - LIWORK, LRWORK, LZWORK - INTEGER, INTENT(OUT) :: K, INFO - REAL(KIND=WP), INTENT(IN) :: TOL -! -! Array arguments -! ~~~~~~~~~~~~~~~ - COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) - COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & - W(LDW,*), S(LDS,*) - COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) - COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) - REAL(KIND=WP), INTENT(OUT) :: RES(*) - REAL(KIND=WP), INTENT(OUT) :: RWORK(*) - INTEGER, INTENT(OUT) :: IWORK(*) -! -! Parameters -! ~~~~~~~~~~ - REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP - REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP - COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP ) - COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP ) -! -! Local scalars -! ~~~~~~~~~~~~~ - REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & - SSUM, XSCL1, XSCL2 - INTEGER :: i, j, IMINWR, INFO1, INFO2, & - LWRKEV, LWRSDD, LWRSVD, LWRSVJ, & - LWRSVQ, MLWORK, MWRKEV, MWRSDD, & - MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & - OLWORK, MLRWRK - LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & - WNTEX, WNTREF, WNTRES, WNTVEC - CHARACTER :: JOBZL, T_OR_N - CHARACTER :: JSVOPT -! -! Local arrays -! ~~~~~~~~~~~~ - REAL(KIND=WP) :: RDUMMY(2) -! -! External functions (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~ - REAL(KIND=WP) CLANGE, SLAMCH, SCNRM2 - EXTERNAL CLANGE, SLAMCH, SCNRM2, ICAMAX - INTEGER ICAMAX - LOGICAL SISNAN, LSAME - EXTERNAL SISNAN, LSAME -! -! External subroutines (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~~~~ - EXTERNAL CAXPY, CGEMM, CSSCAL - EXTERNAL CGEEV, CGEJSV, CGESDD, CGESVD, CGESVDQ, & - CLACPY, CLASCL, CLASSQ, XERBLA -! -! Intrinsic functions -! ~~~~~~~~~~~~~~~~~~~ - INTRINSIC FLOAT, INT, MAX, SQRT -!............................................................ -! -! Test the input arguments -! - WNTRES = LSAME(JOBR,'R') - SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') - SCCOLY = LSAME(JOBS,'Y') - WNTVEC = LSAME(JOBZ,'V') - WNTREF = LSAME(JOBF,'R') - WNTEX = LSAME(JOBF,'E') - INFO = 0 - LQUERY = ( ( LZWORK == -1 ) .OR. ( LIWORK == -1 ) & - .OR. ( LRWORK == -1 ) ) -! - IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & - LSAME(JOBS,'N')) ) THEN - INFO = -1 - ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & - .OR. LSAME(JOBZ,'F')) ) THEN - INFO = -2 - ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & - ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN - INFO = -3 - ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & - LSAME(JOBF,'N') ) ) THEN - INFO = -4 - ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & - (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN - INFO = -5 - ELSE IF ( M < 0 ) THEN - INFO = -6 - ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN - INFO = -7 - ELSE IF ( LDX < M ) THEN - INFO = -9 - ELSE IF ( LDY < M ) THEN - INFO = -11 - ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & - ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN - INFO = -12 - ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN - INFO = -13 - ELSE IF ( LDZ < M ) THEN - INFO = -17 - ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN - INFO = -20 - ELSE IF ( LDW < N ) THEN - INFO = -22 - ELSE IF ( LDS < N ) THEN - INFO = -24 - END IF -! - IF ( INFO == 0 ) THEN - ! Compute the minimal and the optimal workspace - ! requirements. Simulate running the code and - ! determine minimal and optimal sizes of the - ! workspace at any moment of the run. - IF ( N == 0 ) THEN - ! Quick return. All output except K is void. - ! INFO=1 signals the void input. - ! In case of a workspace query, the default - ! minimal workspace lengths are returned. - IF ( LQUERY ) THEN - IWORK(1) = 1 - RWORK(1) = 1 - ZWORK(1) = 2 - ZWORK(2) = 2 - ELSE - K = 0 - END IF - INFO = 1 - RETURN - END IF - - IMINWR = 1 - MLRWRK = MAX(1,N) - MLWORK = 2 - OLWORK = 2 - SELECT CASE ( WHTSVD ) - CASE (1) - ! The following is specified as the minimal - ! length of WORK in the definition of CGESVD: - ! MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) - MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) - MLWORK = MAX(MLWORK,MWRSVD) - MLRWRK = MAX(MLRWRK,N + 5*MIN(M,N)) - IF ( LQUERY ) THEN - CALL CGESVD( 'O', 'S', M, N, X, LDX, RWORK, & - B, LDB, W, LDW, ZWORK, -1, RDUMMY, INFO1 ) - LWRSVD = INT( ZWORK(1) ) - OLWORK = MAX(OLWORK,LWRSVD) - END IF - CASE (2) - ! The following is specified as the minimal - ! length of WORK in the definition of CGESDD: - ! MWRSDD = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). - ! RWORK length: 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N) - ! In LAPACK 3.10.1 RWORK is defined differently. - ! Below we take max over the two versions. - ! IMINWR = 8*MIN(M,N) - MWRSDD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) - MLWORK = MAX(MLWORK,MWRSDD) - IMINWR = 8*MIN(M,N) - MLRWRK = MAX( MLRWRK, N + & - MAX( 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), & - 5*MIN(M,N)*MIN(M,N)+5*MIN(M,N), & - 2*MAX(M,N)*MIN(M,N)+ & - 2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) - IF ( LQUERY ) THEN - CALL CGESDD( 'O', M, N, X, LDX, RWORK, B, & - LDB, W, LDW, ZWORK, -1, RDUMMY, IWORK, INFO1 ) - LWRSDD = MAX(MWRSDD,INT( ZWORK(1) )) - OLWORK = MAX(OLWORK,LWRSDD) - END IF - CASE (3) - CALL CGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, RWORK, Z, LDZ, W, LDW, NUMRNK, & - IWORK, -1, ZWORK, -1, RDUMMY, -1, INFO1 ) - IMINWR = IWORK(1) - MWRSVQ = INT(ZWORK(2)) - MLWORK = MAX(MLWORK,MWRSVQ) - MLRWRK = MAX(MLRWRK,N + INT(RDUMMY(1))) - IF ( LQUERY ) THEN - LWRSVQ = INT(ZWORK(1)) - OLWORK = MAX(OLWORK,LWRSVQ) - END IF - CASE (4) - JSVOPT = 'J' - CALL CGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & - N, X, LDX, RWORK, Z, LDZ, W, LDW, & - ZWORK, -1, RDUMMY, -1, IWORK, INFO1 ) - IMINWR = IWORK(1) - MWRSVJ = INT(ZWORK(2)) - MLWORK = MAX(MLWORK,MWRSVJ) - MLRWRK = MAX(MLRWRK,N + MAX(7,INT(RDUMMY(1)))) - IF ( LQUERY ) THEN - LWRSVJ = INT(ZWORK(1)) - OLWORK = MAX(OLWORK,LWRSVJ) - END IF - END SELECT - IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN - JOBZL = 'V' - ELSE - JOBZL = 'N' - END IF - ! Workspace calculation to the CGEEV call - MWRKEV = MAX( 1, 2*N ) - MLWORK = MAX(MLWORK,MWRKEV) - MLRWRK = MAX(MLRWRK,N+2*N) - IF ( LQUERY ) THEN - CALL CGEEV( 'N', JOBZL, N, S, LDS, EIGS, & - W, LDW, W, LDW, ZWORK, -1, RWORK, INFO1 ) ! LAPACK CALL - LWRKEV = INT(ZWORK(1)) - OLWORK = MAX( OLWORK, LWRKEV ) - OLWORK = MAX( 2, OLWORK ) - END IF -! - IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -30 - IF ( LRWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -28 - IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -26 - - END IF -! - IF( INFO /= 0 ) THEN - CALL XERBLA( 'CGEDMD', -INFO ) - RETURN - ELSE IF ( LQUERY ) THEN -! Return minimal and optimal workspace sizes - IWORK(1) = IMINWR - RWORK(1) = MLRWRK - ZWORK(1) = MLWORK - ZWORK(2) = OLWORK - RETURN - END IF -!............................................................ -! - OFL = SLAMCH('O')*SLAMCH('P') - SMALL = SLAMCH('S') - BADXY = .FALSE. -! -! <1> Optional scaling of the snapshots (columns of X, Y) -! ========================================================== - IF ( SCCOLX ) THEN - ! The columns of X will be normalized. - ! To prevent overflows, the column norms of X are - ! carefully computed using CLASSQ. - K = 0 - DO i = 1, N - !WORK(i) = SCNRM2( M, X(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL CLASSQ( M, X(1,i), 1, SCALE, SSUM ) - IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN - K = 0 - INFO = -8 - CALL XERBLA('CGEDMD',-INFO) - END IF - IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of X(:,i) overflows. First, X(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. -! Next, the norm of X(:,i) is stored without -! overflow as WORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of X(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL CLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, X(1,i), LDX, INFO2 ) - RWORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - RWORK(i) = SCALE * ROOTSC - CALL CLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & - X(1,i), LDX, INFO2 ) ! LAPACK CALL -! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC - END IF - ELSE - RWORK(i) = ZERO - K = K + 1 - END IF - END DO - IF ( K == N ) THEN - ! All columns of X are zero. Return error code -8. - ! (the 8th input variable had an illegal value) - K = 0 - INFO = -8 - CALL XERBLA('CGEDMD',-INFO) - RETURN - END IF - DO i = 1, N -! Now, apply the same scaling to the columns of Y. - IF ( RWORK(i) > ZERO ) THEN - CALL CSSCAL( M, ONE/RWORK(i), Y(1,i), 1 ) ! BLAS CALL -! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC - ELSE IF ( RWORK(i) < ZERO ) THEN - CALL CLASCL( 'G', 0, 0, -RWORK(i), & - ONE/FLOAT(M), M, 1, Y(1,i), LDY, INFO2 ) ! LAPACK CALL - ELSE IF ( ABS(Y(ICAMAX(M, Y(1,i),1),i )) & - /= ZERO ) THEN -! X(:,i) is zero vector. For consistency, -! Y(:,i) should also be zero. If Y(:,i) is not -! zero, then the data might be inconsistent or -! corrupted. If JOBS == 'C', Y(:,i) is set to -! zero and a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - IF ( LSAME(JOBS,'C')) & - CALL CSSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL - END IF - END DO - END IF - ! - IF ( SCCOLY ) THEN - ! The columns of Y will be normalized. - ! To prevent overflows, the column norms of Y are - ! carefully computed using CLASSQ. - DO i = 1, N - !RWORK(i) = SCNRM2( M, Y(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL CLASSQ( M, Y(1,i), 1, SCALE, SSUM ) - IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN - K = 0 - INFO = -10 - CALL XERBLA('CGEDMD',-INFO) - END IF - IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of Y(:,i) overflows. First, Y(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. -! Next, the norm of Y(:,i) is stored without -! overflow as RWORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of Y(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL CLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, Y(1,i), LDY, INFO2 ) - RWORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) - ELSE -! Y(:,i) will be scaled to unit 2-norm - RWORK(i) = SCALE * ROOTSC - CALL CLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & - Y(1,i), LDY, INFO2 ) ! LAPACK CALL -! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC - END IF - ELSE - RWORK(i) = ZERO - END IF - END DO - DO i = 1, N -! Now, apply the same scaling to the columns of X. - IF ( RWORK(i) > ZERO ) THEN - CALL CSSCAL( M, ONE/RWORK(i), X(1,i), 1 ) ! BLAS CALL -! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC - ELSE IF ( RWORK(i) < ZERO ) THEN - CALL CLASCL( 'G', 0, 0, -RWORK(i), & - ONE/FLOAT(M), M, 1, X(1,i), LDX, INFO2 ) ! LAPACK CALL - ELSE IF ( ABS(X(ICAMAX(M, X(1,i),1),i )) & - /= ZERO ) THEN -! Y(:,i) is zero vector. If X(:,i) is not -! zero, then a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - END IF - END DO - END IF -! -! <2> SVD of the data snapshot matrix X. -! ===================================== -! The left singular vectors are stored in the array X. -! The right singular vectors are in the array W. -! The array W will later on contain the eigenvectors -! of a Rayleigh quotient. - NUMRNK = N - SELECT CASE ( WHTSVD ) - CASE (1) - CALL CGESVD( 'O', 'S', M, N, X, LDX, RWORK, B, & - LDB, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL - T_OR_N = 'C' - CASE (2) - CALL CGESDD( 'O', M, N, X, LDX, RWORK, B, LDB, W, & - LDW, ZWORK, LZWORK, RWORK(N+1), IWORK, INFO1 ) ! LAPACK CALL - T_OR_N = 'C' - CASE (3) - CALL CGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, RWORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, LIWORK, ZWORK, & - LZWORK, RWORK(N+1), LRWORK-N, INFO1) ! LAPACK CALL - CALL CLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'C' - CASE (4) - CALL CGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & - N, X, LDX, RWORK, Z, LDZ, W, LDW, & - ZWORK, LZWORK, RWORK(N+1), LRWORK-N, IWORK, INFO1 ) ! LAPACK CALL - CALL CLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'N' - XSCL1 = RWORK(N+1) - XSCL2 = RWORK(N+2) - IF ( XSCL1 /= XSCL2 ) THEN - ! This is an exceptional situation. If the - ! data matrices are not scaled and the - ! largest singular value of X overflows. - ! In that case CGEJSV can return the SVD - ! in scaled form. The scaling factor can be used - ! to rescale the data (X and Y). - CALL CLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) - END IF - END SELECT -! - IF ( INFO1 > 0 ) THEN - ! The SVD selected subroutine did not converge. - ! Return with an error code. - INFO = 2 - RETURN - END IF -! - IF ( RWORK(1) == ZERO ) THEN - ! The largest computed singular value of (scaled) - ! X is zero. Return error code -8 - ! (the 8th input variable had an illegal value). - K = 0 - INFO = -8 - CALL XERBLA('CGEDMD',-INFO) - RETURN - END IF -! - !<3> Determine the numerical rank of the data - ! snapshots matrix X. This depends on the - ! parameters NRNK and TOL. - - SELECT CASE ( NRNK ) - CASE ( -1 ) - K = 1 - DO i = 2, NUMRNK - IF ( ( RWORK(i) <= RWORK(1)*TOL ) .OR. & - ( RWORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE ( -2 ) - K = 1 - DO i = 1, NUMRNK-1 - IF ( ( RWORK(i+1) <= RWORK(i)*TOL ) .OR. & - ( RWORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE DEFAULT - K = 1 - DO i = 2, NRNK - IF ( RWORK(i) <= SMALL ) EXIT - K = K + 1 - END DO - END SELECT - ! Now, U = X(1:M,1:K) is the SVD/POD basis for the - ! snapshot data in the input matrix X. - - !<4> Compute the Rayleigh quotient S = U^H * A * U. - ! Depending on the requested outputs, the computation - ! is organized to compute additional auxiliary - ! matrices (for the residuals and refinements). - ! - ! In all formulas below, we need V_k*Sigma_k^(-1) - ! where either V_k is in W(1:N,1:K), or V_k^H is in - ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). - IF ( LSAME(T_OR_N, 'N') ) THEN - DO i = 1, K - CALL CSSCAL( N, ONE/RWORK(i), W(1,i), 1 ) ! BLAS CALL - ! W(1:N,i) = (ONE/RWORK(i)) * W(1:N,i) ! INTRINSIC - END DO - ELSE - ! This non-unit stride access is due to the fact - ! that CGESVD, CGESVDQ and CGESDD return the - ! adjoint matrix of the right singular vectors. - !DO i = 1, K - ! CALL DSCAL( N, ONE/RWORK(i), W(i,1), LDW ) ! BLAS CALL - ! ! W(i,1:N) = (ONE/RWORK(i)) * W(i,1:N) ! INTRINSIC - !END DO - DO i = 1, K - RWORK(N+i) = ONE/RWORK(i) - END DO - DO j = 1, N - DO i = 1, K - W(i,j) = CMPLX(RWORK(N+i),ZERO,KIND=WP)*W(i,j) - END DO - END DO - END IF -! - IF ( WNTREF ) THEN - ! - ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) - ! for computing the refined Ritz vectors - ! (optionally, outside CGEDMD). - CALL CGEMM( 'N', T_OR_N, M, K, N, ZONE, Y, LDY, W, & - LDW, ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' - ! - ! At this point Z contains - ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and - ! this is needed for computing the residuals. - ! This matrix is returned in the array B and - ! it can be used to compute refined Ritz vectors. - CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL - ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC - - CALL CGEMM( 'C', 'N', K, K, M, ZONE, X, LDX, Z, & - LDZ, ZZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC - ! At this point S = U^H * A * U is the Rayleigh quotient. - ELSE - ! A * U(:,1:K) is not explicitly needed and the - ! computation is organized differently. The Rayleigh - ! quotient is computed more efficiently. - CALL CGEMM( 'C', 'N', K, N, M, ZONE, X, LDX, Y, LDY, & - ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC - ! - CALL CGEMM( 'N', T_OR_N, K, K, N, ZONE, Z, LDZ, W, & - LDW, ZZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' - ! At this point S = U^H * A * U is the Rayleigh quotient. - ! If the residuals are requested, save scaled V_k into Z. - ! Recall that V_k or V_k^H is stored in W. - IF ( WNTRES .OR. WNTEX ) THEN - IF ( LSAME(T_OR_N, 'N') ) THEN - CALL CLACPY( 'A', N, K, W, LDW, Z, LDZ ) - ELSE - CALL CLACPY( 'A', K, N, W, LDW, Z, LDZ ) - END IF - END IF - END IF -! - !<5> Compute the Ritz values and (if requested) the - ! right eigenvectors of the Rayleigh quotient. - ! - CALL CGEEV( 'N', JOBZL, K, S, LDS, EIGS, W, & - LDW, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL - ! - ! W(1:K,1:K) contains the eigenvectors of the Rayleigh - ! quotient. See the description of Z. - ! Also, see the description of CGEEV. - IF ( INFO1 > 0 ) THEN - ! CGEEV failed to compute the eigenvalues and - ! eigenvectors of the Rayleigh quotient. - INFO = 3 - RETURN - END IF -! - ! <6> Compute the eigenvectors (if requested) and, - ! the residuals (if requested). - ! - IF ( WNTVEC .OR. WNTEX ) THEN - IF ( WNTRES ) THEN - IF ( WNTREF ) THEN - ! Here, if the refinement is requested, we have - ! A*U(:,1:K) already computed and stored in Z. - ! For the residuals, need Y = A * U(:,1;K) * W. - CALL CGEMM( 'N', 'N', M, K, K, ZONE, Z, LDZ, W, & - LDW, ZZERO, Y, LDY ) ! BLAS CALL - ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC - ! This frees Z; Y contains A * U(:,1:K) * W. - ELSE - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) (or its adjoint) is stored in Z - CALL CGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & - W, LDW, ZZERO, S, LDS) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - LDS, ZZERO, Z, LDZ) - ! Save a copy of Z into Y and free Z for holding - ! the Ritz vectors. - CALL CLACPY( 'A', M, K, Z, LDZ, Y, LDY ) - IF ( WNTEX ) CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF - ELSE IF ( WNTEX ) THEN - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL CGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & - W, LDW, ZZERO, S, LDS) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - LDS, ZZERO, B, LDB) - ! The above call replaces the following two calls - ! that were used in the developing-testing phase. - ! CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - ! LDS, ZZERO, Z, LDZ) - ! Save a copy of Z into Y and free Z for holding - ! the Ritz vectors. - ! CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF -! - ! Compute the Ritz vectors - IF ( WNTVEC ) CALL CGEMM( 'N', 'N', M, K, K, ZONE, X, LDX, W, LDW, & - ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC -! - IF ( WNTRES ) THEN - DO i = 1, K - CALL CAXPY( M, -EIGS(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL - ! Y(1:M,i) = Y(1:M,i) - EIGS(i) * Z(1:M,i) ! INTRINSIC - RES(i) = SCNRM2( M, Y(1,i), 1) ! BLAS CALL - END DO - END IF - END IF -! - IF ( WHTSVD == 4 ) THEN - RWORK(N+1) = XSCL1 - RWORK(N+2) = XSCL2 - END IF -! -! Successful exit. - IF ( .NOT. BADXY ) THEN - INFO = 0 - ELSE - ! A warning on possible data inconsistency. - ! This should be a rare event. - INFO = 4 - END IF -!............................................................ - RETURN -! ...... - END SUBROUTINE CGEDMD - +!> \brief \b CGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. +! +! =========== DOCUMENTATION =========== +! +! Definition: +! =========== +! +! SUBROUTINE CGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & +! M, N, X, LDX, Y, LDY, NRNK, TOL, & +! K, EIGS, Z, LDZ, RES, B, LDB, & +! W, LDW, S, LDS, ZWORK, LZWORK, & +! RWORK, LRWORK, IWORK, LIWORK, INFO ) +!..... +! USE, INTRINSIC :: iso_fortran_env, only: real32 +! IMPLICIT NONE +! INTEGER, PARAMETER :: WP = real32 +! +!..... +! Scalar arguments +! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF +! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & +! NRNK, LDZ, LDB, LDW, LDS, & +! LIWORK, LRWORK, LZWORK +! INTEGER, INTENT(OUT) :: K, INFO +! REAL(KIND=WP), INTENT(IN) :: TOL +! Array arguments +! COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) +! COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & +! W(LDW,*), S(LDS,*) +! COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) +! COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) +! REAL(KIND=WP), INTENT(OUT) :: RES(*) +! REAL(KIND=WP), INTENT(OUT) :: RWORK(*) +! INTEGER, INTENT(OUT) :: IWORK(*) +! +!............................................................ +!> \par Purpose: +! ============= +!> \verbatim +!> CGEDMD computes the Dynamic Mode Decomposition (DMD) for +!> a pair of data snapshot matrices. For the input matrices +!> X and Y such that Y = A*X with an unaccessible matrix +!> A, CGEDMD computes a certain number of Ritz pairs of A using +!> the standard Rayleigh-Ritz extraction from a subspace of +!> range(X) that is determined using the leading left singular +!> vectors of X. Optionally, CGEDMD returns the residuals +!> of the computed Ritz pairs, the information needed for +!> a refinement of the Ritz vectors, or the eigenvectors of +!> the Exact DMD. +!> For further details see the references listed +!> below. For more details of the implementation see [3]. +!> \endverbatim +!............................................................ +!> \par References: +! ================ +!> \verbatim +!> [1] P. Schmid: Dynamic mode decomposition of numerical +!> and experimental data, +!> Journal of Fluid Mechanics 656, 5-28, 2010. +!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal +!> decompositions: analysis and enhancements, +!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. +!> [3] Z. Drmac: A LAPACK implementation of the Dynamic +!> Mode Decomposition I. Technical report. AIMDyn Inc. +!> and LAPACK Working Note 298. +!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. +!> Brunton, N. Kutz: On Dynamic Mode Decomposition: +!> Theory and Applications, Journal of Computational +!> Dynamics 1(2), 391 -421, 2014. +!> \endverbatim +!...................................................................... +!> \par Developed and supported by: +! ================================ +!> \verbatim +!> Developed and coded by Zlatko Drmac, Faculty of Science, +!> University of Zagreb; drmac@math.hr +!> In cooperation with +!> AIMdyn Inc., Santa Barbara, CA. +!> and supported by +!> - DARPA SBIR project "Koopman Operator-Based Forecasting +!> for Nonstationary Processes from Near-Term, Limited +!> Observational Data" Contract No: W31P4Q-21-C-0007 +!> - DARPA PAI project "Physics-Informed Machine Learning +!> Methodologies" Contract No: HR0011-18-9-0033 +!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic +!> Framework for Space-Time Analysis of Process Dynamics" +!> Contract No: HR0011-16-C-0116 +!> Any opinions, findings and conclusions or recommendations +!> expressed in this material are those of the author and +!> do not necessarily reflect the views of the DARPA SBIR +!> Program Office +!> \endverbatim +!...................................................................... +!> \par Distribution Statement A: +! ============================== +!> \verbatim +!> Approved for Public Release, Distribution Unlimited. +!> Cleared by DARPA on September 29, 2022 +!> \endverbatim +!...................................................................... +! Arguments +! ========= +! +!> \param[in] JOBS +!> \verbatim +!> JOBS (input) CHARACTER*1 +!> Determines whether the initial data snapshots are scaled +!> by a diagonal matrix. +!> 'S' :: The data snapshots matrices X and Y are multiplied +!> with a diagonal matrix D so that X*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'C' :: The snapshots are scaled as with the 'S' option. +!> If it is found that an i-th column of X is zero +!> vector and the corresponding i-th column of Y is +!> non-zero, then the i-th column of Y is set to +!> zero and a warning flag is raised. +!> 'Y' :: The data snapshots matrices X and Y are multiplied +!> by a diagonal matrix D so that Y*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'N' :: No data scaling. +!> \endverbatim +!..... +!> \param[in] JOBZ +!> \verbatim +!> JOBZ (input) CHARACTER*1 +!> Determines whether the eigenvectors (Koopman modes) will +!> be computed. +!> 'V' :: The eigenvectors (Koopman modes) will be computed +!> and returned in the matrix Z. +!> See the description of Z. +!> 'F' :: The eigenvectors (Koopman modes) will be returned +!> in factored form as the product X(:,1:K)*W, where X +!> contains a POD basis (leading left singular vectors +!> of the data matrix X) and W contains the eigenvectors +!> of the corresponding Rayleigh quotient. +!> See the descriptions of K, X, W, Z. +!> 'N' :: The eigenvectors are not computed. +!> \endverbatim +!..... +!> \param[in] JOBR +!> \verbatim +!> JOBR (input) CHARACTER*1 +!> Determines whether to compute the residuals. +!> 'R' :: The residuals for the computed eigenpairs will be +!> computed and stored in the array RES. +!> See the description of RES. +!> For this option to be legal, JOBZ must be 'V'. +!> 'N' :: The residuals are not computed. +!> \endverbatim +!..... +!> \param[in] JOBF +!> \verbatim +!> JOBF (input) CHARACTER*1 +!> Specifies whether to store information needed for post- +!> processing (e.g. computing refined Ritz vectors) +!> 'R' :: The matrix needed for the refinement of the Ritz +!> vectors is computed and stored in the array B. +!> See the description of B. +!> 'E' :: The unscaled eigenvectors of the Exact DMD are +!> computed and returned in the array B. See the +!> description of B. +!> 'N' :: No eigenvector refinement data is computed. +!> \endverbatim +!..... +!> \param[in] WHTSVD +!> \verbatim +!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } +!> Allows for a selection of the SVD algorithm from the +!> LAPACK library. +!> 1 :: CGESVD (the QR SVD algorithm) +!> 2 :: CGESDD (the Divide and Conquer algorithm; if enough +!> workspace available, this is the fastest option) +!> 3 :: CGESVDQ (the preconditioned QR SVD ; this and 4 +!> are the most accurate options) +!> 4 :: CGEJSV (the preconditioned Jacobi SVD; this and 3 +!> are the most accurate options) +!> For the four methods above, a significant difference in +!> the accuracy of small singular values is possible if +!> the snapshots vary in norm so that X is severely +!> ill-conditioned. If small (smaller than EPS*||X||) +!> singular values are of interest and JOBS=='N', then +!> the options (3, 4) give the most accurate results, where +!> the option 4 is slightly better and with stronger +!> theoretical background. +!> If JOBS=='S', i.e. the columns of X will be normalized, +!> then all methods give nearly equally accurate results. +!> \endverbatim +!..... +!> \param[in] M +!> \verbatim +!> M (input) INTEGER, M>= 0 +!> The state space dimension (the row dimension of X, Y). +!> \endverbatim +!..... +!> \param[in] N +!> \verbatim +!> N (input) INTEGER, 0 <= N <= M +!> The number of data snapshot pairs +!> (the number of columns of X and Y). +!> \endverbatim +!..... +!> \param[in,out] X +!> \verbatim +!> X (input/output) COMPLEX(KIND=WP) M-by-N array +!> > On entry, X contains the data snapshot matrix X. It is +!> assumed that the column norms of X are in the range of +!> the normalized floating point numbers. +!> < On exit, the leading K columns of X contain a POD basis, +!> i.e. the leading K left singular vectors of the input +!> data matrix X, U(:,1:K). All N columns of X contain all +!> left singular vectors of the input matrix X. +!> See the descriptions of K, Z and W. +!> \endverbatim +!..... +!> \param[in] LDX +!> \verbatim +!> LDX (input) INTEGER, LDX >= M +!> The leading dimension of the array X. +!> \endverbatim +!..... +!> \param[in,out] Y +!> \verbatim +!> Y (input/workspace/output) COMPLEX(KIND=WP) M-by-N array +!> > On entry, Y contains the data snapshot matrix Y +!> < On exit, +!> If JOBR == 'R', the leading K columns of Y contain +!> the residual vectors for the computed Ritz pairs. +!> See the description of RES. +!> If JOBR == 'N', Y contains the original input data, +!> scaled according to the value of JOBS. +!> \endverbatim +!..... +!> \param[in] LDY +!> \verbatim +!> LDY (input) INTEGER , LDY >= M +!> The leading dimension of the array Y. +!> \endverbatim +!..... +!> \param[in] NRNK +!> \verbatim +!> NRNK (input) INTEGER +!> Determines the mode how to compute the numerical rank, +!> i.e. how to truncate small singular values of the input +!> matrix X. On input, if +!> NRNK = -1 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(1) +!> This option is recommended. +!> NRNK = -2 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(i-1) +!> This option is included for R&D purposes. +!> It requires highly accurate SVD, which +!> may not be feasible. +!> The numerical rank can be enforced by using positive +!> value of NRNK as follows: +!> 0 < NRNK <= N :: at most NRNK largest singular values +!> will be used. If the number of the computed nonzero +!> singular values is less than NRNK, then only those +!> nonzero values will be used and the actually used +!> dimension is less than NRNK. The actual number of +!> the nonzero singular values is returned in the variable +!> K. See the descriptions of TOL and K. +!> \endverbatim +!..... +!> \param[in] TOL +!> \verbatim +!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 +!> The tolerance for truncating small singular values. +!> See the description of NRNK. +!> \endverbatim +!..... +!> \param[out] K +!> \verbatim +!> K (output) INTEGER, 0 <= K <= N +!> The dimension of the POD basis for the data snapshot +!> matrix X and the number of the computed Ritz pairs. +!> The value of K is determined according to the rule set +!> by the parameters NRNK and TOL. +!> See the descriptions of NRNK and TOL. +!> \endverbatim +!..... +!> \param[out] EIGS +!> \verbatim +!> EIGS (output) COMPLEX(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of EIGS contain +!> the computed eigenvalues (Ritz values). +!> See the descriptions of K, and Z. +!> \endverbatim +!..... +!> \param[out] Z +!> \verbatim +!> Z (workspace/output) COMPLEX(KIND=WP) M-by-N array +!> If JOBZ =='V' then Z contains the Ritz vectors. Z(:,i) +!> is an eigenvector of the i-th Ritz value; ||Z(:,i)||_2=1. +!> If JOBZ == 'F', then the Z(:,i)'s are given implicitly as +!> the columns of X(:,1:K)*W(1:K,1:K), i.e. X(:,1:K)*W(:,i) +!> is an eigenvector corresponding to EIGS(i). The columns +!> of W(1:k,1:K) are the computed eigenvectors of the +!> K-by-K Rayleigh quotient. +!> See the descriptions of EIGS, X and W. +!> \endverbatim +!..... +!> \param[in] LDZ +!> \verbatim +!> LDZ (input) INTEGER , LDZ >= M +!> The leading dimension of the array Z. +!> \endverbatim +!..... +!> \param[out] RES +!> \verbatim +!> RES (output) REAL(KIND=WP) N-by-1 array +!> RES(1:K) contains the residuals for the K computed +!> Ritz pairs, +!> RES(i) = || A * Z(:,i) - EIGS(i)*Z(:,i))||_2. +!> See the description of EIGS and Z. +!> \endverbatim +!..... +!> \param[out] B +!> \verbatim +!> B (output) COMPLEX(KIND=WP) M-by-N array. +!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can +!> be used for computing the refined vectors; see further +!> details in the provided references. +!> If JOBF == 'E', B(1:M,1:K) contains +!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the +!> Exact DMD, up to scaling by the inverse eigenvalues. +!> If JOBF =='N', then B is not referenced. +!> See the descriptions of X, W, K. +!> \endverbatim +!..... +!> \param[in] LDB +!> \verbatim +!> LDB (input) INTEGER, LDB >= M +!> The leading dimension of the array B. +!> \endverbatim +!..... +!> \param[out] W +!> \verbatim +!> W (workspace/output) COMPLEX(KIND=WP) N-by-N array +!> On exit, W(1:K,1:K) contains the K computed +!> eigenvectors of the matrix Rayleigh quotient. +!> The Ritz vectors (returned in Z) are the +!> product of X (containing a POD basis for the input +!> matrix X) and W. See the descriptions of K, S, X and Z. +!> W is also used as a workspace to temporarily store the +!> right singular vectors of X. +!> \endverbatim +!..... +!> \param[in] LDW +!> \verbatim +!> LDW (input) INTEGER, LDW >= N +!> The leading dimension of the array W. +!> \endverbatim +!..... +!> \param[out] S +!> \verbatim +!> S (workspace/output) COMPLEX(KIND=WP) N-by-N array +!> The array S(1:K,1:K) is used for the matrix Rayleigh +!> quotient. This content is overwritten during +!> the eigenvalue decomposition by CGEEV. +!> See the description of K. +!> \endverbatim +!..... +!> \param[in] LDS +!> \verbatim +!> LDS (input) INTEGER, LDS >= N +!> The leading dimension of the array S. +!> \endverbatim +!..... +!> \param[out] ZWORK +!> \verbatim +!> ZWORK (workspace/output) COMPLEX(KIND=WP) LZWORK-by-1 array +!> ZWORK is used as complex workspace in the complex SVD, as +!> specified by WHTSVD (1,2, 3 or 4) and for CGEEV for computing +!> the eigenvalues of a Rayleigh quotient. +!> If the call to CGEDMD is only workspace query, then +!> ZWORK(1) contains the minimal complex workspace length and +!> ZWORK(2) is the optimal complex workspace length. +!> Hence, the length of work is at least 2. +!> See the description of LZWORK. +!> \endverbatim +!..... +!> \param[in] LZWORK +!> \verbatim +!> LZWORK (input) INTEGER +!> The minimal length of the workspace vector ZWORK. +!> LZWORK is calculated as MAX(LZWORK_SVD, LZWORK_CGEEV), +!> where LZWORK_CGEEV = MAX( 1, 2*N ) and the minimal +!> LZWORK_SVD is calculated as follows +!> If WHTSVD == 1 :: CGESVD :: +!> LZWORK_SVD = MAX(1,2*MIN(M,N)+MAX(M,N)) +!> If WHTSVD == 2 :: CGESDD :: +!> LZWORK_SVD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) +!> If WHTSVD == 3 :: CGESVDQ :: +!> LZWORK_SVD = obtainable by a query +!> If WHTSVD == 4 :: CGEJSV :: +!> LZWORK_SVD = obtainable by a query +!> If on entry LZWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths and returns them in +!> LZWORK(1) and LZWORK(2), respectively. +!> \endverbatim +!..... +!> \param[out] RWORK +!> \verbatim +!> RWORK (workspace/output) REAL(KIND=WP) LRWORK-by-1 array +!> On exit, RWORK(1:N) contains the singular values of +!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). +!> If WHTSVD==4, then RWORK(N+1) and RWORK(N+2) contain +!> scaling factor RWORK(N+2)/RWORK(N+1) used to scale X +!> and Y to avoid overflow in the SVD of X. +!> This may be of interest if the scaling option is off +!> and as many as possible smallest eigenvalues are +!> desired to the highest feasible accuracy. +!> If the call to CGEDMD is only workspace query, then +!> RWORK(1) contains the minimal workspace length. +!> See the description of LRWORK. +!> \endverbatim +!..... +!> \param[in] LRWORK +!> \verbatim +!> LRWORK (input) INTEGER +!> The minimal length of the workspace vector RWORK. +!> LRWORK is calculated as follows: +!> LRWORK = MAX(1, N+LRWORK_SVD,N+LRWORK_CGEEV), where +!> LRWORK_CGEEV = MAX(1,2*N) and RWORK_SVD is the real workspace +!> for the SVD subroutine determined by the input parameter +!> WHTSVD. +!> If WHTSVD == 1 :: CGESVD :: +!> LRWORK_SVD = 5*MIN(M,N) +!> If WHTSVD == 2 :: CGESDD :: +!> LRWORK_SVD = MAX(5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), +!> 2*MAX(M,N)*MIN(M,N)+2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) +!> If WHTSVD == 3 :: CGESVDQ :: +!> LRWORK_SVD = obtainable by a query +!> If WHTSVD == 4 :: CGEJSV :: +!> LRWORK_SVD = obtainable by a query +!> If on entry LRWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> real workspace length and returns it in RWORK(1). +!> \endverbatim +!..... +!> \param[out] IWORK +!> \verbatim +!> IWORK (workspace/output) INTEGER LIWORK-by-1 array +!> Workspace that is required only if WHTSVD equals +!> 2 , 3 or 4. (See the description of WHTSVD). +!> If on entry LWORK =-1 or LIWORK=-1, then the +!> minimal length of IWORK is computed and returned in +!> IWORK(1). See the description of LIWORK. +!> \endverbatim +!..... +!> \param[in] LIWORK +!> \verbatim +!> LIWORK (input) INTEGER +!> The minimal length of the workspace vector IWORK. +!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 +!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) +!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) +!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) +!> If on entry LIWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for ZWORK, RWORK and +!> IWORK. See the descriptions of ZWORK, RWORK and IWORK. +!> \endverbatim +!..... +!> \param[out] INFO +!> \verbatim +!> INFO (output) INTEGER +!> -i < 0 :: On entry, the i-th argument had an +!> illegal value +!> = 0 :: Successful return. +!> = 1 :: Void input. Quick exit (M=0 or N=0). +!> = 2 :: The SVD computation of X did not converge. +!> Suggestion: Check the input data and/or +!> repeat with different WHTSVD. +!> = 3 :: The computation of the eigenvalues did not +!> converge. +!> = 4 :: If data scaling was requested on input and +!> the procedure found inconsistency in the data +!> such that for some column index i, +!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set +!> to zero if JOBS=='C'. The computation proceeds +!> with original or modified data and warning +!> flag is set with INFO=4. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Zlatko Drmac +! +!> \ingroup gedmd +! +!............................................................. +!............................................................. + SUBROUTINE CGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, EIGS, Z, LDZ, RES, B, LDB, & + W, LDW, S, LDS, ZWORK, LZWORK, & + RWORK, LRWORK, IWORK, LIWORK, INFO ) +! +! -- LAPACK driver routine -- +! +! -- LAPACK is a software package provided by University of -- +! -- Tennessee, University of California Berkeley, University of -- +! -- Colorado Denver and NAG Ltd.. -- +! +!..... + USE, INTRINSIC :: iso_fortran_env, only: real32 + IMPLICIT NONE + INTEGER, PARAMETER :: WP = real32 +! +! Scalar arguments +! ~~~~~~~~~~~~~~~~ + CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF + INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & + NRNK, LDZ, LDB, LDW, LDS, & + LIWORK, LRWORK, LZWORK + INTEGER, INTENT(OUT) :: K, INFO + REAL(KIND=WP), INTENT(IN) :: TOL +! +! Array arguments +! ~~~~~~~~~~~~~~~ + COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) + COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & + W(LDW,*), S(LDS,*) + COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) + COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) + REAL(KIND=WP), INTENT(OUT) :: RES(*) + REAL(KIND=WP), INTENT(OUT) :: RWORK(*) + INTEGER, INTENT(OUT) :: IWORK(*) +! +! Parameters +! ~~~~~~~~~~ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP + COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP ) + COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP ) +! +! Local scalars +! ~~~~~~~~~~~~~ + REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & + SSUM, XSCL1, XSCL2, TBIG + INTEGER :: i, j, IMINWR, INFO1, INFO2, & + LWRKEV, LWRSDD, LWRSVD, LWRSVJ, & + LWRSVQ, MLWORK, MWRKEV, MWRSDD, & + MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & + OLWORK, MLRWRK + LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & + WNTEX, WNTREF, WNTRES, WNTVEC + CHARACTER :: JOBZL, T_OR_N + CHARACTER :: JSVOPT +! +! Local arrays +! ~~~~~~~~~~~~ + REAL(KIND=WP) :: RDUMMY(2) +! +! External functions (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~ + REAL(KIND=WP) CLANGE, SLAMCH, SCNRM2 + EXTERNAL CLANGE, SLAMCH, SCNRM2, ICAMAX + INTEGER ICAMAX + LOGICAL SISNAN, LSAME + EXTERNAL SISNAN, LSAME +! +! External subroutines (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~~~~ + EXTERNAL CAXPY, CGEMM, CSSCAL + EXTERNAL CGEEV, CGEJSV, CGESDD, CGESVD, CGESVDQ, & + CLACPY, CLASCL, CLASSQ, XERBLA +! +! Intrinsic functions +! ~~~~~~~~~~~~~~~~~~~ + INTRINSIC FLOAT, INT, MAX, SQRT +!............................................................ +! +! Test the input arguments +! + WNTRES = LSAME(JOBR,'R') + SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') + SCCOLY = LSAME(JOBS,'Y') + WNTVEC = LSAME(JOBZ,'V') + WNTREF = LSAME(JOBF,'R') + WNTEX = LSAME(JOBF,'E') + INFO = 0 + LQUERY = ( ( LZWORK == -1 ) .OR. ( LIWORK == -1 ) & + .OR. ( LRWORK == -1 ) ) +! + IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & + LSAME(JOBS,'N')) ) THEN + INFO = -1 + ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & + .OR. LSAME(JOBZ,'F')) ) THEN + INFO = -2 + ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & + ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN + INFO = -3 + ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & + LSAME(JOBF,'N') ) ) THEN + INFO = -4 + ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & + (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN + INFO = -5 + ELSE IF ( M < 0 ) THEN + INFO = -6 + ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN + INFO = -7 + ELSE IF ( LDX < M ) THEN + INFO = -9 + ELSE IF ( LDY < M ) THEN + INFO = -11 + ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & + ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN + INFO = -12 + ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN + INFO = -13 + ELSE IF ( LDZ < M ) THEN + INFO = -17 + ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN + INFO = -20 + ELSE IF ( LDW < N ) THEN + INFO = -22 + ELSE IF ( LDS < N ) THEN + INFO = -24 + END IF +! + IF ( INFO == 0 ) THEN + ! Compute the minimal and the optimal workspace + ! requirements. Simulate running the code and + ! determine minimal and optimal sizes of the + ! workspace at any moment of the run. + IF ( N == 0 ) THEN + ! Quick return. All output except K is void. + ! INFO=1 signals the void input. + ! In case of a workspace query, the default + ! minimal workspace lengths are returned. + IF ( LQUERY ) THEN + IWORK(1) = 1 + RWORK(1) = 1 + ZWORK(1) = 2 + ZWORK(2) = 2 + ELSE + K = 0 + END IF + INFO = 1 + RETURN + END IF + + IMINWR = 1 + MLRWRK = MAX(1,N) + MLWORK = 2 + OLWORK = 2 + SELECT CASE ( WHTSVD ) + CASE (1) + ! The following is specified as the minimal + ! length of WORK in the definition of CGESVD: + ! MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) + MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) + MLWORK = MAX(MLWORK,MWRSVD) + MLRWRK = MAX(MLRWRK,N + 5*MIN(M,N)) + IF ( LQUERY ) THEN + CALL CGESVD( 'O', 'S', M, N, X, LDX, RWORK, & + B, LDB, W, LDW, ZWORK, -1, RDUMMY, INFO1 ) + LWRSVD = INT( ZWORK(1) ) + OLWORK = MAX(OLWORK,LWRSVD) + END IF + CASE (2) + ! The following is specified as the minimal + ! length of WORK in the definition of CGESDD: + ! MWRSDD = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). + ! RWORK length: 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N) + ! In LAPACK 3.10.1 RWORK is defined differently. + ! Below we take max over the two versions. + ! IMINWR = 8*MIN(M,N) + MWRSDD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) + MLWORK = MAX(MLWORK,MWRSDD) + IMINWR = 8*MIN(M,N) + MLRWRK = MAX( MLRWRK, N + & + MAX( 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), & + 5*MIN(M,N)*MIN(M,N)+5*MIN(M,N), & + 2*MAX(M,N)*MIN(M,N)+ & + 2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) + IF ( LQUERY ) THEN + CALL CGESDD( 'O', M, N, X, LDX, RWORK, B, & + LDB, W, LDW, ZWORK, -1, RDUMMY, IWORK, INFO1 ) + LWRSDD = MAX(MWRSDD,INT( ZWORK(1) )) + OLWORK = MAX(OLWORK,LWRSDD) + END IF + CASE (3) + CALL CGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, RWORK, Z, LDZ, W, LDW, NUMRNK, & + IWORK, -1, ZWORK, -1, RDUMMY, -1, INFO1 ) + IMINWR = IWORK(1) + MWRSVQ = INT(ZWORK(2)) + MLWORK = MAX(MLWORK,MWRSVQ) + MLRWRK = MAX(MLRWRK,N + INT(RDUMMY(1))) + IF ( LQUERY ) THEN + LWRSVQ = INT(ZWORK(1)) + OLWORK = MAX(OLWORK,LWRSVQ) + END IF + CASE (4) + JSVOPT = 'J' + CALL CGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & + N, X, LDX, RWORK, Z, LDZ, W, LDW, & + ZWORK, -1, RDUMMY, -1, IWORK, INFO1 ) + IMINWR = IWORK(1) + MWRSVJ = INT(ZWORK(2)) + MLWORK = MAX(MLWORK,MWRSVJ) + MLRWRK = MAX(MLRWRK,N + MAX(7,INT(RDUMMY(1)))) + IF ( LQUERY ) THEN + LWRSVJ = INT(ZWORK(1)) + OLWORK = MAX(OLWORK,LWRSVJ) + END IF + END SELECT + IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN + JOBZL = 'V' + ELSE + JOBZL = 'N' + END IF + ! Workspace calculation to the CGEEV call + MWRKEV = MAX( 1, 2*N ) + MLWORK = MAX(MLWORK,MWRKEV) + MLRWRK = MAX(MLRWRK,N+2*N) + IF ( LQUERY ) THEN + CALL CGEEV( 'N', JOBZL, N, S, LDS, EIGS, & + W, LDW, W, LDW, ZWORK, -1, RWORK, INFO1 ) ! LAPACK CALL + LWRKEV = INT(ZWORK(1)) + OLWORK = MAX( OLWORK, LWRKEV ) + OLWORK = MAX( 2, OLWORK ) + END IF +! + IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -30 + IF ( LRWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -28 + IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -26 + + END IF +! + IF( INFO /= 0 ) THEN + CALL XERBLA( 'CGEDMD', -INFO ) + RETURN + ELSE IF ( LQUERY ) THEN +! Return minimal and optimal workspace sizes + IWORK(1) = IMINWR + RWORK(1) = REAL(MLRWRK) + ZWORK(1) = CMPLX(MLWORK) + ZWORK(2) = CMPLX(OLWORK) + RETURN + END IF +!............................................................ +! + OFL = SLAMCH('O')*SLAMCH('P') + SMALL = SLAMCH('S') + BADXY = .FALSE. +! +! <1> Optional scaling of the snapshots (columns of X, Y) +! ========================================================== + IF ( SCCOLX ) THEN + ! The columns of X will be normalized. + ! To prevent overflows, the column norms of X are + ! carefully computed using CLASSQ. + K = 0 + DO i = 1, N + !WORK(i) = SCNRM2( M, X(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL CLASSQ( M, X(1,i), 1, SCALE, SSUM ) + IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN + K = 0 + INFO = -8 + CALL XERBLA('CGEDMD',-INFO) + END IF + IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of X(:,i) overflows. First, X(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. +! Next, the norm of X(:,i) is stored without +! overflow as WORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of X(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL CLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, X(1,i), LDX, INFO2 ) + RWORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + RWORK(i) = SCALE * ROOTSC + CALL CLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & + X(1,i), LDX, INFO2 ) ! LAPACK CALL +! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC + END IF + ELSE + RWORK(i) = ZERO + K = K + 1 + END IF + END DO + IF ( K == N ) THEN + ! All columns of X are zero. Return error code -8. + ! (the 8th input variable had an illegal value) + K = 0 + INFO = -8 + CALL XERBLA('CGEDMD',-INFO) + RETURN + END IF + DO i = 1, N +! Now, apply the same scaling to the columns of Y. + IF ( RWORK(i) > ZERO ) THEN + CALL CSSCAL( M, ONE/RWORK(i), Y(1,i), 1 ) ! BLAS CALL +! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC + ELSE IF ( RWORK(i) < ZERO ) THEN + CALL CLASCL( 'G', 0, 0, -RWORK(i), & + ONE/FLOAT(M), M, 1, Y(1,i), LDY, INFO2 ) ! LAPACK CALL + ELSE IF ( ABS(Y(ICAMAX(M, Y(1,i),1),i )) & + /= ZERO ) THEN +! X(:,i) is zero vector. For consistency, +! Y(:,i) should also be zero. If Y(:,i) is not +! zero, then the data might be inconsistent or +! corrupted. If JOBS == 'C', Y(:,i) is set to +! zero and a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + IF ( LSAME(JOBS,'C')) & + CALL CSSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL + END IF + END DO + END IF + ! + IF ( SCCOLY ) THEN + ! The columns of Y will be normalized. + ! To prevent overflows, the column norms of Y are + ! carefully computed using CLASSQ. + DO i = 1, N + !RWORK(i) = SCNRM2( M, Y(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL CLASSQ( M, Y(1,i), 1, SCALE, SSUM ) + IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN + K = 0 + INFO = -10 + CALL XERBLA('CGEDMD',-INFO) + END IF + IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of Y(:,i) overflows. First, Y(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. +! Next, the norm of Y(:,i) is stored without +! overflow as RWORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of Y(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL CLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, Y(1,i), LDY, INFO2 ) + RWORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) + ELSE +! Y(:,i) will be scaled to unit 2-norm + RWORK(i) = SCALE * ROOTSC + CALL CLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & + Y(1,i), LDY, INFO2 ) ! LAPACK CALL +! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC + END IF + ELSE + RWORK(i) = ZERO + END IF + END DO + DO i = 1, N +! Now, apply the same scaling to the columns of X. + IF ( RWORK(i) > ZERO ) THEN + CALL CSSCAL( M, ONE/RWORK(i), X(1,i), 1 ) ! BLAS CALL +! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC + ELSE IF ( RWORK(i) < ZERO ) THEN + CALL CLASCL( 'G', 0, 0, -RWORK(i), & + ONE/FLOAT(M), M, 1, X(1,i), LDX, INFO2 ) ! LAPACK CALL + ELSE IF ( ABS(X(ICAMAX(M, X(1,i),1),i )) & + /= ZERO ) THEN +! Y(:,i) is zero vector. If X(:,i) is not +! zero, then a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + END IF + END DO + END IF +! +! <2> SVD of the data snapshot matrix X. +! ===================================== +! The left singular vectors are stored in the array X. +! The right singular vectors are in the array W. +! The array W will later on contain the eigenvectors +! of a Rayleigh quotient. + NUMRNK = N + SELECT CASE ( WHTSVD ) + CASE (1) + CALL CGESVD( 'O', 'S', M, N, X, LDX, RWORK, B, & + LDB, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL + T_OR_N = 'C' + CASE (2) + CALL CGESDD( 'O', M, N, X, LDX, RWORK, B, LDB, W, & + LDW, ZWORK, LZWORK, RWORK(N+1), IWORK, INFO1 ) ! LAPACK CALL + T_OR_N = 'C' + CASE (3) + CALL CGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, RWORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, LIWORK, ZWORK, & + LZWORK, RWORK(N+1), LRWORK-N, INFO1) ! LAPACK CALL + CALL CLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'C' + CASE (4) + CALL CGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & + N, X, LDX, RWORK, Z, LDZ, W, LDW, & + ZWORK, LZWORK, RWORK(N+1), LRWORK-N, IWORK, INFO1 ) ! LAPACK CALL + CALL CLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'N' + XSCL1 = RWORK(N+1) + XSCL2 = RWORK(N+2) + IF ( XSCL1 /= XSCL2 ) THEN + ! This is an exceptional situation. If the + ! data matrices are not scaled and the + ! largest singular value of X overflows. + ! In that case CGEJSV can return the SVD + ! in scaled form. The scaling factor can be used + ! to rescale the data (X and Y). + CALL CLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) + END IF + END SELECT +! + IF ( INFO1 > 0 ) THEN + ! The SVD selected subroutine did not converge. + ! Return with an error code. + INFO = 2 + RETURN + END IF +! + IF ( RWORK(1) == ZERO ) THEN + ! The largest computed singular value of (scaled) + ! X is zero. Return error code -8 + ! (the 8th input variable had an illegal value). + K = 0 + INFO = -8 + CALL XERBLA('CGEDMD',-INFO) + RETURN + END IF +! + !<3> Determine the numerical rank of the data + ! snapshots matrix X. This depends on the + ! parameters NRNK and TOL. + + SELECT CASE ( NRNK ) + CASE ( -1 ) + K = 1 + DO i = 2, NUMRNK + IF ( ( RWORK(i) <= RWORK(1)*TOL ) .OR. & + ( RWORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE ( -2 ) + K = 1 + DO i = 1, NUMRNK-1 + IF ( ( RWORK(i+1) <= RWORK(i)*TOL ) .OR. & + ( RWORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE DEFAULT + K = 1 + DO i = 2, NRNK + IF ( RWORK(i) <= SMALL ) EXIT + K = K + 1 + END DO + END SELECT + ! Now, U = X(1:M,1:K) is the SVD/POD basis for the + ! snapshot data in the input matrix X. + + !<4> Compute the Rayleigh quotient S = U^H * A * U. + ! Depending on the requested outputs, the computation + ! is organized to compute additional auxiliary + ! matrices (for the residuals and refinements). + ! + ! In all formulas below, we need V_k*Sigma_k^(-1) + ! where either V_k is in W(1:N,1:K), or V_k^H is in + ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). + IF ( LSAME(T_OR_N, 'N') ) THEN + DO i = 1, K + CALL CSSCAL( N, ONE/RWORK(i), W(1,i), 1 ) ! BLAS CALL + ! W(1:N,i) = (ONE/RWORK(i)) * W(1:N,i) ! INTRINSIC + END DO + ELSE + ! This non-unit stride access is due to the fact + ! that CGESVD, CGESVDQ and CGESDD return the + ! adjoint matrix of the right singular vectors. + !DO i = 1, K + ! CALL DSCAL( N, ONE/RWORK(i), W(i,1), LDW ) ! BLAS CALL + ! ! W(i,1:N) = (ONE/RWORK(i)) * W(i,1:N) ! INTRINSIC + !END DO + DO i = 1, K + RWORK(N+i) = ONE/RWORK(i) + END DO + DO j = 1, N + DO i = 1, K + W(i,j) = CMPLX(RWORK(N+i),ZERO,KIND=WP)*W(i,j) + END DO + END DO + END IF +! + IF ( WNTREF ) THEN + ! + ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) + ! for computing the refined Ritz vectors + ! (optionally, outside CGEDMD). + CALL CGEMM( 'N', T_OR_N, M, K, N, ZONE, Y, LDY, W, & + LDW, ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' + ! + ! At this point Z contains + ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and + ! this is needed for computing the residuals. + ! This matrix is returned in the array B and + ! it can be used to compute refined Ritz vectors. + CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL + ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC + + CALL CGEMM( 'C', 'N', K, K, M, ZONE, X, LDX, Z, & + LDZ, ZZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC + ! At this point S = U^H * A * U is the Rayleigh quotient. + ELSE + ! A * U(:,1:K) is not explicitly needed and the + ! computation is organized differently. The Rayleigh + ! quotient is computed more efficiently. + CALL CGEMM( 'C', 'N', K, N, M, ZONE, X, LDX, Y, LDY, & + ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC + ! + CALL CGEMM( 'N', T_OR_N, K, K, N, ZONE, Z, LDZ, W, & + LDW, ZZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' + ! At this point S = U^H * A * U is the Rayleigh quotient. + ! If the residuals are requested, save scaled V_k into Z. + ! Recall that V_k or V_k^H is stored in W. + IF ( WNTRES .OR. WNTEX ) THEN + IF ( LSAME(T_OR_N, 'N') ) THEN + CALL CLACPY( 'A', N, K, W, LDW, Z, LDZ ) + ELSE + CALL CLACPY( 'A', K, N, W, LDW, Z, LDZ ) + END IF + END IF + END IF +! + !<5> Compute the Ritz values and (if requested) the + ! right eigenvectors of the Rayleigh quotient. + ! + CALL CGEEV( 'N', JOBZL, K, S, LDS, EIGS, W, & + LDW, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL + ! + ! W(1:K,1:K) contains the eigenvectors of the Rayleigh + ! quotient. See the description of Z. + ! Also, see the description of CGEEV. + IF ( INFO1 > 0 ) THEN + ! CGEEV failed to compute the eigenvalues and + ! eigenvectors of the Rayleigh quotient. + INFO = 3 + RETURN + END IF +! + ! <6> Compute the eigenvectors (if requested) and, + ! the residuals (if requested). + ! + IF ( WNTVEC .OR. WNTEX ) THEN + IF ( WNTRES ) THEN + IF ( WNTREF ) THEN + ! Here, if the refinement is requested, we have + ! A*U(:,1:K) already computed and stored in Z. + ! For the residuals, need Y = A * U(:,1;K) * W. + CALL CGEMM( 'N', 'N', M, K, K, ZONE, Z, LDZ, W, & + LDW, ZZERO, Y, LDY ) ! BLAS CALL + ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC + ! This frees Z; Y contains A * U(:,1:K) * W. + ELSE + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) (or its adjoint) is stored in Z + CALL CGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & + W, LDW, ZZERO, S, LDS) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + LDS, ZZERO, Z, LDZ) + ! Save a copy of Z into Y and free Z for holding + ! the Ritz vectors. + CALL CLACPY( 'A', M, K, Z, LDZ, Y, LDY ) + IF ( WNTEX ) CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF + ELSE IF ( WNTEX ) THEN + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL CGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & + W, LDW, ZZERO, S, LDS) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + LDS, ZZERO, B, LDB) + ! The above call replaces the following two calls + ! that were used in the developing-testing phase. + ! CALL CGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + ! LDS, ZZERO, Z, LDZ) + ! Save a copy of Z into Y and free Z for holding + ! the Ritz vectors. + ! CALL CLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF +! + ! Compute the Ritz vectors + IF ( WNTVEC ) CALL CGEMM( 'N', 'N', M, K, K, ZONE, X, LDX, W, LDW, & + ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC +! + IF ( WNTRES ) THEN + DO i = 1, K + CALL CAXPY( M, -EIGS(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL + ! Y(1:M,i) = Y(1:M,i) - EIGS(i) * Z(1:M,i) ! INTRINSIC + RES(i) = SCNRM2( M, Y(1,i), 1) ! BLAS CALL + END DO + END IF + END IF +! + IF ( WHTSVD == 4 ) THEN + RWORK(N+1) = XSCL1 + RWORK(N+2) = XSCL2 + END IF +! +! Successful exit. + IF ( .NOT. BADXY ) THEN + INFO = 0 + ELSE + ! A warning on possible data inconsistency. + ! This should be a rare event. + INFO = 4 + END IF +!............................................................ + RETURN +! ...... + END SUBROUTINE CGEDMD diff --git a/lapack-netlib/SRC/cgejsv.f b/lapack-netlib/SRC/cgejsv.f index 1fc75613ed..55afcb90a9 100644 --- a/lapack-netlib/SRC/cgejsv.f +++ b/lapack-netlib/SRC/cgejsv.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEJSV + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -21,9 +19,9 @@ * SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * M, N, A, LDA, SVA, U, LDU, V, LDV, * CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* IMPLICIT NONE * * .. Scalar Arguments .. -* IMPLICIT NONE * INTEGER INFO, LDA, LDU, LDV, LWORK, M, N * .. * .. Array Arguments .. @@ -484,7 +482,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEsing +*> \ingroup gejsv * *> \par Further Details: * ===================== @@ -565,13 +563,13 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ M, N, A, LDA, SVA, U, LDU, V, LDV, $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - IMPLICIT NONE INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N * .. * .. Array Arguments .. @@ -593,7 +591,7 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, COMPLEX CTEMP REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, $ CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, - $ SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC + $ SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC, TBIG INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LQUERY, $ LSVEC, L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, NOSCAL, @@ -620,10 +618,10 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, EXTERNAL ISAMAX, ICAMAX, LSAME, SLAMCH, SCNRM2 * .. * .. External Subroutines .. - EXTERNAL SLASSQ, CCOPY, CGELQF, CGEQP3, CGEQRF, CLACPY, CLAPMR, - $ CLASCL, SLASCL, CLASET, CLASSQ, CLASWP, CUNGQR, CUNMLQ, - $ CUNMQR, CPOCON, SSCAL, CSSCAL, CSWAP, CTRSM, CLACGV, - $ XERBLA + EXTERNAL SLASSQ, CCOPY, CGELQF, CGEQP3, CGEQRF, CLACPY, + $ CLAPMR, CLASCL, SLASCL, CLASET, CLASSQ, CLASWP, + $ CUNGQR, CUNMLQ, CUNMQR, CPOCON, SSCAL, CSSCAL, + $ CSWAP, CTRSM, CLACGV, XERBLA * EXTERNAL CGESVJ * .. @@ -655,7 +653,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, INFO = - 3 ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN INFO = - 4 - ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. LSAME(JOBT,'N') ) ) THEN + ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. + $ LSAME(JOBT,'N') ) ) THEN INFO = - 5 ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN INFO = - 6 @@ -722,7 +721,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, MINWRK = MAX( N+LWQP3, N+LWQRF, LWSVDJ ) END IF IF ( LQUERY ) THEN - CALL CGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, V, + CALL CGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, + $ V, $ LDV, CDUMMY, -1, RDUMMY, -1, IERR ) LWRK_CGESVJ = INT( CDUMMY(1) ) IF ( ERREST ) THEN @@ -866,7 +866,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ LDU, CDUMMY, -1, IERR ) LWRK_CUNMQR = INT( CDUMMY(1) ) IF ( .NOT. JRACC ) THEN - CALL CGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, -1, + CALL CGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, + $ -1, $ RDUMMY, IERR ) LWRK_CGEQP3N = INT( CDUMMY(1) ) CALL CGESVJ( 'L', 'U', 'N', N, N, U, LDU, SVA, @@ -910,10 +911,12 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL CGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) LWRK_CGESVJV = INT( CDUMMY(1) ) - CALL CUNMQR( 'L', 'N', N, N, N, CDUMMY, N, CDUMMY, + CALL CUNMQR( 'L', 'N', N, N, N, CDUMMY, N, + $ CDUMMY, $ V, LDV, CDUMMY, -1, IERR ) LWRK_CUNMQR = INT( CDUMMY(1) ) - CALL CUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + CALL CUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, + $ U, $ LDU, CDUMMY, -1, IERR ) LWRK_CUNMQRM = INT( CDUMMY(1) ) IF ( ERREST ) THEN @@ -946,9 +949,9 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL XERBLA( 'CGEJSV', - INFO ) RETURN ELSE IF ( LQUERY ) THEN - CWORK(1) = OPTWRK - CWORK(2) = MINWRK - RWORK(1) = MINRWRK + CWORK(1) = CMPLX( OPTWRK ) + CWORK(2) = CMPLX( MINWRK ) + RWORK(1) = REAL( MINRWRK ) IWORK(1) = MAX( 4, MINIWRK ) RETURN END IF @@ -997,7 +1000,9 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, RETURN END IF AAQQ = SQRT(AAQQ) - IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF ( ( AAPP .LT. TBIG ) .AND. NOSCAL ) THEN SVA(p) = AAPP * AAQQ ELSE NOSCAL = .FALSE. @@ -1061,15 +1066,20 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL CLACPY( 'A', M, 1, A, LDA, U, LDU ) * computing all M left singular vectors of the M x 1 matrix IF ( N1 .NE. N ) THEN - CALL CGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) - CALL CUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) + CALL CGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N, + $ IERR ) + CALL CUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N, + $ IERR ) CALL CCOPY( M, A(1,1), 1, U(1,1), 1 ) END IF END IF IF ( RSVEC ) THEN V(1,1) = CONE END IF - IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + TBIG = BIG + IF ( SCALEM .EQ. ZERO ) SCALEM = ONE + IF ( SCALEM .LT. ONE) TBIG = BIG*SCALEM + IF ( SVA(1) .LT. TBIG ) THEN SVA(1) = SVA(1) / SCALEM SCALEM = ONE END IF @@ -1493,7 +1503,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * * .. second preconditioning using the QR factorization * - CALL CGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) + CALL CGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, + $ IERR ) * * .. and transpose upper to lower triangular DO 1948 p = 1, NR - 1 @@ -1520,7 +1531,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 1949 CONTINUE 1947 CONTINUE ELSE - CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), + $ LDA ) END IF * * .. and one-sided Jacobi rotations are started on a lower @@ -1560,7 +1572,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * accumulated product of Jacobi rotations, three are perfect ) * CALL CLASET( 'L', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) - CALL CGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) + CALL CGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, + $ IERR) CALL CLACPY( 'L', NR, NR, A, LDA, V, LDV ) CALL CLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) CALL CGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), @@ -1576,9 +1589,12 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, SCALEM = RWORK(1) NUMRANK = NINT(RWORK(2)) IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) - CALL CLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) - CALL CLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) + CALL CLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), + $ LDV ) + CALL CLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), + $ LDV ) + CALL CLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1), + $ LDV ) END IF * CALL CUNMLQ( 'L', 'C', N, N, NR, A, LDA, CWORK, @@ -1633,10 +1649,13 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, NUMRANK = NINT(RWORK(2)) * IF ( NR .LT. M ) THEN - CALL CLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) + CALL CLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), + $ LDU ) IF ( NR .LT. N1 ) THEN - CALL CLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) - CALL CLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) + CALL CLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1), + $ LDU ) + CALL CLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1), + $ LDU ) END IF END IF * @@ -1700,7 +1719,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 2968 CONTINUE 2969 CONTINUE ELSE - CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), + $ LDV ) END IF * * Estimate the row scaled condition number of R1 @@ -1809,7 +1829,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL CLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) DO 4950 p = 1, NR TEMP1 = SCNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) - CALL CSSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) + CALL CSSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), + $ NR ) 4950 CONTINUE CALL CPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) @@ -1838,7 +1859,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 4969 CONTINUE 4968 CONTINUE ELSE - CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) + CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), + $ LDV ) END IF * * Second preconditioning finished; continue with Jacobi SVD @@ -1866,7 +1888,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * equation is Q2*V2 = the product of the Jacobi rotations * used in CGESVJ, premultiplied with the orthogonal matrix * from the second QR factorization. - CALL CTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) + CALL CTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V, + $ LDV) ELSE * .. R1 is well conditioned, but non-square. Adjoint of R2 * is inverted to get the product of the Jacobi rotations @@ -1877,9 +1900,11 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, IF ( NR .LT. N ) THEN CALL CLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV) CALL CLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV) - CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF - CALL CUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + CALL CUNMQR('L','N',N,N,NR,CWORK(2*N+1),N, + $ CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) END IF * @@ -1889,7 +1914,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * is Q3^* * V3 = the product of the Jacobi rotations (applied to * the lower triangular L3 from the LQ factorization of * R2=L3*Q3), pre-multiplied with the transposed Q3. - CALL CGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + CALL CGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, + $ U, $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, $ RWORK, LRWORK, INFO ) SCALEM = RWORK(1) @@ -1910,9 +1936,12 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 874 CONTINUE 873 CONTINUE IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1), + $ LDV ) + CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1), + $ LDV ) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) @@ -1928,15 +1957,19 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * defense ensures that CGEJSV completes the task. * Compute the full SVD of L3 using CGESVJ with explicit * accumulation of Jacobi rotations. - CALL CGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + CALL CGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, + $ U, $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, $ RWORK, LRWORK, INFO ) SCALEM = RWORK(1) NUMRANK = NINT(RWORK(2)) IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1), + $ LDV ) + CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1), + $ LDV ) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) @@ -1974,7 +2007,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * At this moment, V contains the right singular vectors of A. * Next, assemble the left singular vector matrix U (M x N). IF ( NR .LT. M ) THEN - CALL CLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) + CALL CLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), + $ LDU) IF ( NR .LT. N1 ) THEN CALL CLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) CALL CLASET('A',M-NR,N1-NR,CZERO,CONE, @@ -2048,10 +2082,13 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Assemble the left singular vector matrix U (M x N). * IF ( N .LT. M ) THEN - CALL CLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) + CALL CLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), + $ LDU ) IF ( N .LT. N1 ) THEN - CALL CLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) - CALL CLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) + CALL CLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1), + $ LDU) + CALL CLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1), + $ LDU) END IF END IF CALL CUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, @@ -2163,10 +2200,13 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Next, assemble the left singular vector matrix U (M x N). * IF ( NR .LT. M ) THEN - CALL CLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) + CALL CLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), + $ LDU ) IF ( NR .LT. N1 ) THEN - CALL CLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) - CALL CLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) + CALL CLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1), + $ LDU) + CALL CLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1), + $ LDU) END IF END IF * @@ -2191,7 +2231,8 @@ SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Undo scaling, if necessary (and possible) * IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN - CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, + $ IERR ) USCAL1 = ONE USCAL2 = ONE END IF diff --git a/lapack-netlib/SRC/cgesvdx.f b/lapack-netlib/SRC/cgesvdx.f index e1856a65fd..54b21f8d00 100644 --- a/lapack-netlib/SRC/cgesvdx.f +++ b/lapack-netlib/SRC/cgesvdx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGESVDX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -267,6 +265,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, RWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -305,7 +304,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, REAL DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL CGEBRD, CGELQF, CGEQRF, CLASCL, CLASET, + EXTERNAL CGEBRD, CGELQF, CGEQRF, CLASCL, + $ CLASET, $ CUNMBR, CUNMQR, CUNMLQ, CLACPY, $ SBDSVDX, SLASCL, XERBLA * .. @@ -313,7 +313,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, CLANGE, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, CLANGE, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, + $ CLANGE, SROUNDUP_LWORK * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT @@ -395,7 +396,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MAXWRK = 1 IF( MINMN.GT.0 ) THEN IF( M.GE.N ) THEN - MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( M.GE.MNTHR ) THEN * * Path 1 (M much larger than N) @@ -403,24 +405,28 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = N*(N+5) MAXWRK = N + N*ILAENV(1,'CGEQRF',' ',M,N,-1,-1) MAXWRK = MAX(MAXWRK, - $ N*N+2*N+2*N*ILAENV(1,'CGEBRD',' ',N,N,-1,-1)) + $ N*N+2*N+2*N*ILAENV(1,'CGEBRD',' ',N,N,-1, + $ -1)) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, - $ N*N+2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1)) + $ N*N+2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N, + $ -1)) END IF ELSE * * Path 2 (M at least N, but not much larger) * MINWRK = 3*N + M - MAXWRK = 2*N + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1) + MAXWRK = 2*N + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1, + $ -1) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, $ 2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1)) END IF END IF ELSE - MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M) @@ -428,10 +434,12 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = M*(M+5) MAXWRK = M + M*ILAENV(1,'CGELQF',' ',M,N,-1,-1) MAXWRK = MAX(MAXWRK, - $ M*M+2*M+2*M*ILAENV(1,'CGEBRD',' ',M,M,-1,-1)) + $ M*M+2*M+2*M*ILAENV(1,'CGEBRD',' ',M,M,-1, + $ -1)) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, - $ M*M+2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1)) + $ M*M+2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M, + $ -1)) END IF ELSE * @@ -439,7 +447,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * MINWRK = 3*M + N - MAXWRK = 2*M + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1) + MAXWRK = 2*M + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1, + $ -1) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, $ 2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1)) @@ -560,7 +569,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) + CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), + $ LDU) * * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -636,7 +646,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) + CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), + $ LDU) * * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -835,13 +846,14 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Undo scaling if necessary * - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, + IF( ISCL.EQ.1 .AND. NS.GT.0 ) THEN + IF( ANRM.GT.BIGNUM ) THEN + CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, NS, 1, $ S, MINMN, INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, + ELSE IF( ANRM.LT.SMLNUM ) THEN + CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, NS, 1, $ S, MINMN, INFO ) + ENDIF END IF * * Return optimal workspace in WORK(1) diff --git a/lapack-netlib/SRC/cgesvj.f b/lapack-netlib/SRC/cgesvj.f index b9c8f1709e..cae7a244f4 100644 --- a/lapack-netlib/SRC/cgesvj.f +++ b/lapack-netlib/SRC/cgesvj.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGESVJ + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -101,7 +99,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the input matrix A. 1/SLAMCH('E') > M >= 0. +*> The number of rows of the input matrix A. 1/SLAMCH('E') >= M >= 0. *> \endverbatim *> *> \param[in] N @@ -217,7 +215,7 @@ *> LWORK >= 1, if MIN(M,N) = 0, and LWORK >= M+N, otherwise. *> *> If on entry LWORK = -1, then a workspace query is assumed and -*> no computation is done; CWORK(1) is set to the minial (and optimal) +*> no computation is done; CWORK(1) is set to the minimal (and optimal) *> length of CWORK. *> \endverbatim *> @@ -258,7 +256,7 @@ *> LRWORK >= 1, if MIN(M,N) = 0, and LRWORK >= MAX(6,N), otherwise *> *> If on entry LRWORK = -1, then a workspace query is assumed and -*> no computation is done; RWORK(1) is set to the minial (and optimal) +*> no computation is done; RWORK(1) is set to the minimal (and optimal) *> length of RWORK. *> \endverbatim *> @@ -380,7 +378,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. Local Scalars .. COMPLEX AAPQ, OMPQ REAL AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, - $ BIGTHETA, CS, CTOL, EPSLN, MXAAPQ, + $ BIGTHETA, CS, CTOL, EPSLN, MXAAPQ, TBIG, $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, THSIGN, TOL INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, @@ -413,7 +411,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * from BLAS EXTERNAL CCOPY, CROT, CSSCAL, CSWAP, CAXPY * from LAPACK - EXTERNAL CLASCL, CLASET, CLASSQ, SLASCL, XERBLA + EXTERNAL CLASCL, CLASET, CLASSQ, SLASCL, + $ XERBLA EXTERNAL CGSVJ0, CGSVJ1 * .. * .. Executable Statements .. @@ -439,9 +438,13 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LQUERY = ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 - ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN + ELSE IF( .NOT.( LSVEC .OR. + $ UCTOL .OR. + $ LSAME( JOBU, 'N' ) ) ) THEN INFO = -2 - ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + ELSE IF( .NOT.( RSVEC .OR. + $ APPLV .OR. + $ LSAME( JOBV, 'N' ) ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 @@ -454,8 +457,6 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN INFO = -11 - ELSE IF( UCTOL .AND. ( RWORK( 1 ).LE.ONE ) ) THEN - INFO = -12 ELSE IF( LWORK.LT.LWMIN .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 ELSE IF( LRWORK.LT.LRWMIN .AND. ( .NOT.LQUERY ) ) THEN @@ -487,7 +488,12 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( UCTOL ) THEN * ... user controlled - CTOL = RWORK( 1 ) + IF( RWORK( 1 ).LE.ONE ) THEN + INFO = -12 + RETURN + ELSE + CTOL = RWORK( 1 ) + ENDIF ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN @@ -554,7 +560,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT. TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -579,7 +587,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -604,7 +614,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -784,7 +796,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ V( N4*q+1, N4+1 ), LDV, EPSLN, SFMIN, TOL, 1, $ CWORK( N+1 ), LWORK-N, IERR ) * - CALL CGSVJ0( JOBV, M, N4, A, LDA, CWORK, SVA, MVL, V, LDV, + CALL CGSVJ0( JOBV, M, N4, A, LDA, CWORK, SVA, MVL, V, + $ LDV, $ EPSLN, SFMIN, TOL, 1, CWORK( N+1 ), LWORK-N, $ IERR ) * @@ -796,16 +809,19 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( UPPER ) THEN * * - CALL CGSVJ0( JOBV, N4, N4, A, LDA, CWORK, SVA, MVL, V, LDV, + CALL CGSVJ0( JOBV, N4, N4, A, LDA, CWORK, SVA, MVL, V, + $ LDV, $ EPSLN, SFMIN, TOL, 2, CWORK( N+1 ), LWORK-N, $ IERR ) * - CALL CGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, CWORK( N4+1 ), + CALL CGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, + $ CWORK( N4+1 ), $ SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV, $ EPSLN, SFMIN, TOL, 1, CWORK( N+1 ), LWORK-N, $ IERR ) * - CALL CGSVJ1( JOBV, N2, N2, N4, A, LDA, CWORK, SVA, MVL, V, + CALL CGSVJ1( JOBV, N2, N2, N4, A, LDA, CWORK, SVA, MVL, + $ V, $ LDV, EPSLN, SFMIN, TOL, 1, CWORK( N+1 ), $ LWORK-N, IERR ) * @@ -958,7 +974,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, T = HALF / THETA CS = ONE - CALL CROT( M, A(1,p), 1, A(1,q), 1, + CALL CROT( M, A(1,p), 1, A(1,q), + $ 1, $ CS, CONJG(OMPQ)*T ) IF ( RSVEC ) THEN CALL CROT( MVL, V(1,p), 1, @@ -987,7 +1004,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * - CALL CROT( M, A(1,p), 1, A(1,q), 1, + CALL CROT( M, A(1,p), 1, A(1,q), + $ 1, $ CS, CONJG(OMPQ)*SN ) IF ( RSVEC ) THEN CALL CROT( MVL, V(1,p), 1, @@ -1000,14 +1018,17 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. have to use modified Gram-Schmidt like transformation CALL CCOPY( M, A( 1, p ), 1, $ CWORK(N+1), 1 ) - CALL CLASCL( 'G', 0, 0, AAPP, ONE, M, + CALL CLASCL( 'G', 0, 0, AAPP, ONE, + $ M, $ 1, CWORK(N+1), LDA, $ IERR ) - CALL CLASCL( 'G', 0, 0, AAQQ, ONE, M, + CALL CLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, $ 1, A( 1, q ), LDA, IERR ) CALL CAXPY( M, -AAPQ, CWORK(N+1), 1, $ A( 1, q ), 1 ) - CALL CLASCL( 'G', 0, 0, ONE, AAQQ, M, + CALL CLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, $ 1, A( 1, q ), LDA, IERR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) @@ -1022,7 +1043,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = SCNRM2( M, A( 1, q ), 1 ) + SVA( q ) = SCNRM2( M, A( 1, q ), + $ 1 ) ELSE T = ZERO AAQQ = ONE @@ -1174,7 +1196,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA CS = ONE - CALL CROT( M, A(1,p), 1, A(1,q), 1, + CALL CROT( M, A(1,p), 1, A(1,q), + $ 1, $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN CALL CROT( MVL, V(1,p), 1, @@ -1201,7 +1224,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * - CALL CROT( M, A(1,p), 1, A(1,q), 1, + CALL CROT( M, A(1,p), 1, A(1,q), + $ 1, $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN CALL CROT( MVL, V(1,p), 1, @@ -1215,15 +1239,18 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAPP.GT.AAQQ ) THEN CALL CCOPY( M, A( 1, p ), 1, $ CWORK(N+1), 1 ) - CALL CLASCL( 'G', 0, 0, AAPP, ONE, + CALL CLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, CWORK(N+1),LDA, $ IERR ) - CALL CLASCL( 'G', 0, 0, AAQQ, ONE, + CALL CLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) CALL CAXPY( M, -AAPQ, CWORK(N+1), $ 1, A( 1, q ), 1 ) - CALL CLASCL( 'G', 0, 0, ONE, AAQQ, + CALL CLASCL( 'G', 0, 0, ONE, + $ AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, @@ -1232,15 +1259,18 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE CALL CCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) - CALL CLASCL( 'G', 0, 0, AAQQ, ONE, + CALL CLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, CWORK(N+1),LDA, $ IERR ) - CALL CLASCL( 'G', 0, 0, AAPP, ONE, + CALL CLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) CALL CAXPY( M, -CONJG(AAPQ), $ CWORK(N+1), 1, A( 1, p ), 1 ) - CALL CLASCL( 'G', 0, 0, ONE, AAPP, + CALL CLASCL( 'G', 0, 0, ONE, + $ AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*SQRT( MAX( ZERO, @@ -1256,7 +1286,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = SCNRM2( M, A( 1, q ), 1) + SVA( q ) = SCNRM2( M, A( 1, q ), + $ 1) ELSE T = ZERO AAQQ = ONE @@ -1397,8 +1428,10 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( LSVEC .OR. UCTOL ) THEN DO 1998 p = 1, N4 -* CALL CSSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) - CALL CLASCL( 'G',0,0, SVA(p), ONE, M, 1, A(1,p), M, IERR ) + TEMP1 = ONE + IF( SVA(p).GT.ZERO ) TEMP1 = SVA(p) +* CALL CSSCAL( M, ONE/SVA(p), A( 1, p ), 1 ) + CALL CLASCL( 'G',0,0, TEMP1, ONE, M, 1, A(1,p), M, IERR ) 1998 CONTINUE END IF * @@ -1412,9 +1445,14 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) - $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. - $ ( SFMIN / SKL ) ) ) ) THEN + NOSCALE = .FALSE. + IF ( SKL.GT.ONE ) THEN + IF( SVA( 1 ).LT.( BIG / SKL ) ) NOSCALE = .TRUE. + ELSE IF( SKL.LT.ONE ) THEN + IF ( SVA( MAX( N2, 1 ) ) .GT. + $ ( SFMIN / SKL ) ) NOSCALE = .TRUE. + ENDIF + IF( NOSCALE ) THEN DO 2400 p = 1, N SVA( P ) = SKL*SVA( P ) 2400 CONTINUE diff --git a/lapack-netlib/SRC/dgedmd.f90 b/lapack-netlib/SRC/dgedmd.f90 index 15df48fe91..28257ec5ce 100644 --- a/lapack-netlib/SRC/dgedmd.f90 +++ b/lapack-netlib/SRC/dgedmd.f90 @@ -1,1206 +1,1209 @@ -!> \brief \b DGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. -! -! =========== DOCUMENTATION =========== -! -! Definition: -! =========== -! -! SUBROUTINE DGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & -! M, N, X, LDX, Y, LDY, NRNK, TOL, & -! K, REIG, IMEIG, Z, LDZ, RES, & -! B, LDB, W, LDW, S, LDS, & -! WORK, LWORK, IWORK, LIWORK, INFO ) -! -!..... -! USE iso_fortran_env -! IMPLICIT NONE -! INTEGER, PARAMETER :: WP = real64 -!..... -! Scalar arguments -! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF -! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & -! NRNK, LDZ, LDB, LDW, LDS, & -! LWORK, LIWORK -! INTEGER, INTENT(OUT) :: K, INFO -! REAL(KIND=WP), INTENT(IN) :: TOL -! Array arguments -! REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) -! REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & -! W(LDW,*), S(LDS,*) -! REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & -! RES(*) -! REAL(KIND=WP), INTENT(OUT) :: WORK(*) -! INTEGER, INTENT(OUT) :: IWORK(*) -! -!............................................................ -!> \par Purpose: -! ============= -!> \verbatim -!> DGEDMD computes the Dynamic Mode Decomposition (DMD) for -!> a pair of data snapshot matrices. For the input matrices -!> X and Y such that Y = A*X with an unaccessible matrix -!> A, DGEDMD computes a certain number of Ritz pairs of A using -!> the standard Rayleigh-Ritz extraction from a subspace of -!> range(X) that is determined using the leading left singular -!> vectors of X. Optionally, DGEDMD returns the residuals -!> of the computed Ritz pairs, the information needed for -!> a refinement of the Ritz vectors, or the eigenvectors of -!> the Exact DMD. -!> For further details see the references listed -!> below. For more details of the implementation see [3]. -!> \endverbatim -!............................................................ -!> \par References: -! ================ -!> \verbatim -!> [1] P. Schmid: Dynamic mode decomposition of numerical -!> and experimental data, -!> Journal of Fluid Mechanics 656, 5-28, 2010. -!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal -!> decompositions: analysis and enhancements, -!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. -!> [3] Z. Drmac: A LAPACK implementation of the Dynamic -!> Mode Decomposition I. Technical report. AIMDyn Inc. -!> and LAPACK Working Note 298. -!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. -!> Brunton, N. Kutz: On Dynamic Mode Decomposition: -!> Theory and Applications, Journal of Computational -!> Dynamics 1(2), 391 -421, 2014. -!> \endverbatim -!...................................................................... -!> \par Developed and supported by: -! ================================ -!> \verbatim -!> Developed and coded by Zlatko Drmac, Faculty of Science, -!> University of Zagreb; drmac@math.hr -!> In cooperation with -!> AIMdyn Inc., Santa Barbara, CA. -!> and supported by -!> - DARPA SBIR project "Koopman Operator-Based Forecasting -!> for Nonstationary Processes from Near-Term, Limited -!> Observational Data" Contract No: W31P4Q-21-C-0007 -!> - DARPA PAI project "Physics-Informed Machine Learning -!> Methodologies" Contract No: HR0011-18-9-0033 -!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic -!> Framework for Space-Time Analysis of Process Dynamics" -!> Contract No: HR0011-16-C-0116 -!> Any opinions, findings and conclusions or recommendations -!> expressed in this material are those of the author and -!> do not necessarily reflect the views of the DARPA SBIR -!> Program Office -!> \endverbatim -!...................................................................... -!> \par Distribution Statement A: -! ============================== -!> \verbatim -!> Approved for Public Release, Distribution Unlimited. -!> Cleared by DARPA on September 29, 2022 -!> \endverbatim -!...................................................................... -! Arguments -! ========= -! -!> \param[in] JOBS -!> \verbatim -!> JOBS (input) is CHARACTER*1 -!> Determines whether the initial data snapshots are scaled -!> by a diagonal matrix. -!> 'S' :: The data snapshots matrices X and Y are multiplied -!> with a diagonal matrix D so that X*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'C' :: The snapshots are scaled as with the 'S' option. -!> If it is found that an i-th column of X is zero -!> vector and the corresponding i-th column of Y is -!> non-zero, then the i-th column of Y is set to -!> zero and a warning flag is raised. -!> 'Y' :: The data snapshots matrices X and Y are multiplied -!> by a diagonal matrix D so that Y*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'N' :: No data scaling. -!> \endverbatim -!..... -!> \param[in] JOBZ -!> \verbatim -!> JOBZ (input) CHARACTER*1 -!> Determines whether the eigenvectors (Koopman modes) will -!> be computed. -!> 'V' :: The eigenvectors (Koopman modes) will be computed -!> and returned in the matrix Z. -!> See the description of Z. -!> 'F' :: The eigenvectors (Koopman modes) will be returned -!> in factored form as the product X(:,1:K)*W, where X -!> contains a POD basis (leading left singular vectors -!> of the data matrix X) and W contains the eigenvectors -!> of the corresponding Rayleigh quotient. -!> See the descriptions of K, X, W, Z. -!> 'N' :: The eigenvectors are not computed. -!> \endverbatim -!..... -!> \param[in] JOBR -!> \verbatim -!> JOBR (input) CHARACTER*1 -!> Determines whether to compute the residuals. -!> 'R' :: The residuals for the computed eigenpairs will be -!> computed and stored in the array RES. -!> See the description of RES. -!> For this option to be legal, JOBZ must be 'V'. -!> 'N' :: The residuals are not computed. -!> \endverbatim -!..... -!> \param[in] JOBF -!> \verbatim -!> JOBF (input) CHARACTER*1 -!> Specifies whether to store information needed for post- -!> processing (e.g. computing refined Ritz vectors) -!> 'R' :: The matrix needed for the refinement of the Ritz -!> vectors is computed and stored in the array B. -!> See the description of B. -!> 'E' :: The unscaled eigenvectors of the Exact DMD are -!> computed and returned in the array B. See the -!> description of B. -!> 'N' :: No eigenvector refinement data is computed. -!> \endverbatim -!..... -!> \param[in] WHTSVD -!> \verbatim -!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } -!> Allows for a selection of the SVD algorithm from the -!> LAPACK library. -!> 1 :: DGESVD (the QR SVD algorithm) -!> 2 :: DGESDD (the Divide and Conquer algorithm; if enough -!> workspace available, this is the fastest option) -!> 3 :: DGESVDQ (the preconditioned QR SVD ; this and 4 -!> are the most accurate options) -!> 4 :: DGEJSV (the preconditioned Jacobi SVD; this and 3 -!> are the most accurate options) -!> For the four methods above, a significant difference in -!> the accuracy of small singular values is possible if -!> the snapshots vary in norm so that X is severely -!> ill-conditioned. If small (smaller than EPS*||X||) -!> singular values are of interest and JOBS=='N', then -!> the options (3, 4) give the most accurate results, where -!> the option 4 is slightly better and with stronger -!> theoretical background. -!> If JOBS=='S', i.e. the columns of X will be normalized, -!> then all methods give nearly equally accurate results. -!> \endverbatim -!..... -!> \param[in] M -!> \verbatim -!> M (input) INTEGER, M>= 0 -!> The state space dimension (the row dimension of X, Y). -!> \endverbatim -!..... -!> \param[in] N -!> \verbatim -!> N (input) INTEGER, 0 <= N <= M -!> The number of data snapshot pairs -!> (the number of columns of X and Y). -!> \endverbatim -!..... -!> \param[in,out] X -!> \verbatim -!> X (input/output) REAL(KIND=WP) M-by-N array -!> > On entry, X contains the data snapshot matrix X. It is -!> assumed that the column norms of X are in the range of -!> the normalized floating point numbers. -!> < On exit, the leading K columns of X contain a POD basis, -!> i.e. the leading K left singular vectors of the input -!> data matrix X, U(:,1:K). All N columns of X contain all -!> left singular vectors of the input matrix X. -!> See the descriptions of K, Z and W. -!> \endverbatim -!..... -!> \param[in] LDX -!> \verbatim -!> LDX (input) INTEGER, LDX >= M -!> The leading dimension of the array X. -!> \endverbatim -!..... -!> \param[in,out] Y -!> \verbatim -!> Y (input/workspace/output) REAL(KIND=WP) M-by-N array -!> > On entry, Y contains the data snapshot matrix Y -!> < On exit, -!> If JOBR == 'R', the leading K columns of Y contain -!> the residual vectors for the computed Ritz pairs. -!> See the description of RES. -!> If JOBR == 'N', Y contains the original input data, -!> scaled according to the value of JOBS. -!> \endverbatim -!..... -!> \param[in] LDY -!> \verbatim -!> LDY (input) INTEGER , LDY >= M -!> The leading dimension of the array Y. -!> \endverbatim -!..... -!> \param[in] NRNK -!> \verbatim -!> NRNK (input) INTEGER -!> Determines the mode how to compute the numerical rank, -!> i.e. how to truncate small singular values of the input -!> matrix X. On input, if -!> NRNK = -1 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(1). -!> This option is recommended. -!> NRNK = -2 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(i-1) -!> This option is included for R&D purposes. -!> It requires highly accurate SVD, which -!> may not be feasible. -!> -!> The numerical rank can be enforced by using positive -!> value of NRNK as follows: -!> 0 < NRNK <= N :: at most NRNK largest singular values -!> will be used. If the number of the computed nonzero -!> singular values is less than NRNK, then only those -!> nonzero values will be used and the actually used -!> dimension is less than NRNK. The actual number of -!> the nonzero singular values is returned in the variable -!> K. See the descriptions of TOL and K. -!> \endverbatim -!..... -!> \param[in] TOL -!> \verbatim -!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 -!> The tolerance for truncating small singular values. -!> See the description of NRNK. -!> \endverbatim -!..... -!> \param[out] K -!> \verbatim -!> K (output) INTEGER, 0 <= K <= N -!> The dimension of the POD basis for the data snapshot -!> matrix X and the number of the computed Ritz pairs. -!> The value of K is determined according to the rule set -!> by the parameters NRNK and TOL. -!> See the descriptions of NRNK and TOL. -!> \endverbatim -!..... -!> \param[out] REIG -!> \verbatim -!> REIG (output) REAL(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of REIG contain -!> the real parts of the computed eigenvalues -!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). -!> See the descriptions of K, IMEIG, and Z. -!> \endverbatim -!..... -!> \param[out] IMEIG -!> \verbatim -!> IMEIG (output) REAL(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of IMEIG contain -!> the imaginary parts of the computed eigenvalues -!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). -!> The eigenvalues are determined as follows: -!> If IMEIG(i) == 0, then the corresponding eigenvalue is -!> real, LAMBDA(i) = REIG(i). -!> If IMEIG(i)>0, then the corresponding complex -!> conjugate pair of eigenvalues reads -!> LAMBDA(i) = REIG(i) + sqrt(-1)*IMAG(i) -!> LAMBDA(i+1) = REIG(i) - sqrt(-1)*IMAG(i) -!> That is, complex conjugate pairs have consecutive -!> indices (i,i+1), with the positive imaginary part -!> listed first. -!> See the descriptions of K, REIG, and Z. -!> \endverbatim -!..... -!> \param[out] Z -!> \verbatim -!> Z (workspace/output) REAL(KIND=WP) M-by-N array -!> If JOBZ =='V' then -!> Z contains real Ritz vectors as follows: -!> If IMEIG(i)=0, then Z(:,i) is an eigenvector of -!> the i-th Ritz value; ||Z(:,i)||_2=1. -!> If IMEIG(i) > 0 (and IMEIG(i+1) < 0) then -!> [Z(:,i) Z(:,i+1)] span an invariant subspace and -!> the Ritz values extracted from this subspace are -!> REIG(i) + sqrt(-1)*IMEIG(i) and -!> REIG(i) - sqrt(-1)*IMEIG(i). -!> The corresponding eigenvectors are -!> Z(:,i) + sqrt(-1)*Z(:,i+1) and -!> Z(:,i) - sqrt(-1)*Z(:,i+1), respectively. -!> || Z(:,i:i+1)||_F = 1. -!> If JOBZ == 'F', then the above descriptions hold for -!> the columns of X(:,1:K)*W(1:K,1:K), where the columns -!> of W(1:k,1:K) are the computed eigenvectors of the -!> K-by-K Rayleigh quotient. The columns of W(1:K,1:K) -!> are similarly structured: If IMEIG(i) == 0 then -!> X(:,1:K)*W(:,i) is an eigenvector, and if IMEIG(i)>0 -!> then X(:,1:K)*W(:,i)+sqrt(-1)*X(:,1:K)*W(:,i+1) and -!> X(:,1:K)*W(:,i)-sqrt(-1)*X(:,1:K)*W(:,i+1) -!> are the eigenvectors of LAMBDA(i), LAMBDA(i+1). -!> See the descriptions of REIG, IMEIG, X and W. -!> \endverbatim -!..... -!> \param[in] LDZ -!> \verbatim -!> LDZ (input) INTEGER , LDZ >= M -!> The leading dimension of the array Z. -!> \endverbatim -!..... -!> \param[out] RES -!> \verbatim -!> RES (output) REAL(KIND=WP) N-by-1 array -!> RES(1:K) contains the residuals for the K computed -!> Ritz pairs. -!> If LAMBDA(i) is real, then -!> RES(i) = || A * Z(:,i) - LAMBDA(i)*Z(:,i))||_2. -!> If [LAMBDA(i), LAMBDA(i+1)] is a complex conjugate pair -!> then -!> RES(i)=RES(i+1) = || A * Z(:,i:i+1) - Z(:,i:i+1) *B||_F -!> where B = [ real(LAMBDA(i)) imag(LAMBDA(i)) ] -!> [-imag(LAMBDA(i)) real(LAMBDA(i)) ]. -!> It holds that -!> RES(i) = || A*ZC(:,i) - LAMBDA(i) *ZC(:,i) ||_2 -!> RES(i+1) = || A*ZC(:,i+1) - LAMBDA(i+1)*ZC(:,i+1) ||_2 -!> where ZC(:,i) = Z(:,i) + sqrt(-1)*Z(:,i+1) -!> ZC(:,i+1) = Z(:,i) - sqrt(-1)*Z(:,i+1) -!> See the description of REIG, IMEIG and Z. -!> \endverbatim -!..... -!> \param[out] B -!> \verbatim -!> B (output) REAL(KIND=WP) M-by-N array. -!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can -!> be used for computing the refined vectors; see further -!> details in the provided references. -!> If JOBF == 'E', B(1:M,1;K) contains -!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the -!> Exact DMD, up to scaling by the inverse eigenvalues. -!> If JOBF =='N', then B is not referenced. -!> See the descriptions of X, W, K. -!> \endverbatim -!..... -!> \param[in] LDB -!> \verbatim -!> LDB (input) INTEGER, LDB >= M -!> The leading dimension of the array B. -!> \endverbatim -!..... -!> \param[out] W -!> \verbatim -!> W (workspace/output) REAL(KIND=WP) N-by-N array -!> On exit, W(1:K,1:K) contains the K computed -!> eigenvectors of the matrix Rayleigh quotient (real and -!> imaginary parts for each complex conjugate pair of the -!> eigenvalues). The Ritz vectors (returned in Z) are the -!> product of X (containing a POD basis for the input -!> matrix X) and W. See the descriptions of K, S, X and Z. -!> W is also used as a workspace to temporarily store the -!> right singular vectors of X. -!> \endverbatim -!..... -!> \param[in] LDW -!> \verbatim -!> LDW (input) INTEGER, LDW >= N -!> The leading dimension of the array W. -!> \endverbatim -!..... -!> \param[out] S -!> \verbatim -!> S (workspace/output) REAL(KIND=WP) N-by-N array -!> The array S(1:K,1:K) is used for the matrix Rayleigh -!> quotient. This content is overwritten during -!> the eigenvalue decomposition by DGEEV. -!> See the description of K. -!> \endverbatim -!..... -!> \param[in] LDS -!> \verbatim -!> LDS (input) INTEGER, LDS >= N -!> The leading dimension of the array S. -!> \endverbatim -!..... -!> \param[out] WORK -!> \verbatim -!> WORK (workspace/output) REAL(KIND=WP) LWORK-by-1 array -!> On exit, WORK(1:N) contains the singular values of -!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). -!> If WHTSVD==4, then WORK(N+1) and WORK(N+2) contain -!> scaling factor WORK(N+2)/WORK(N+1) used to scale X -!> and Y to avoid overflow in the SVD of X. -!> This may be of interest if the scaling option is off -!> and as many as possible smallest eigenvalues are -!> desired to the highest feasible accuracy. -!> If the call to DGEDMD is only workspace query, then -!> WORK(1) contains the minimal workspace length and -!> WORK(2) is the optimal workspace length. Hence, the -!> leng of work is at least 2. -!> See the description of LWORK. -!> \endverbatim -!..... -!> \param[in] LWORK -!> \verbatim -!> LWORK (input) INTEGER -!> The minimal length of the workspace vector WORK. -!> LWORK is calculated as follows: -!> If WHTSVD == 1 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)). -!> If JOBZ == 'N' then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)). -!> Here LWORK_SVD = MAX(1,3*N+M,5*N) is the minimal -!> workspace length of DGESVD. -!> If WHTSVD == 2 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)) -!> Here LWORK_SVD = MAX(M, 5*N*N+4*N)+3*N*N is the -!> minimal workspace length of DGESDD. -!> If WHTSVD == 3 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) -!> Here LWORK_SVD = N+M+MAX(3*N+1, -!> MAX(1,3*N+M,5*N),MAX(1,N)) -!> is the minimal workspace length of DGESVDQ. -!> If WHTSVD == 4 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) -!> Here LWORK_SVD = MAX(7,2*M+N,6*N+2*N*N) is the -!> minimal workspace length of DGEJSV. -!> The above expressions are not simplified in order to -!> make the usage of WORK more transparent, and for -!> easier checking. In any case, LWORK >= 2. -!> If on entry LWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for both WORK and -!> IWORK. See the descriptions of WORK and IWORK. -!> \endverbatim -!..... -!> \param[out] IWORK -!> \verbatim -!> IWORK (workspace/output) INTEGER LIWORK-by-1 array -!> Workspace that is required only if WHTSVD equals -!> 2 , 3 or 4. (See the description of WHTSVD). -!> If on entry LWORK =-1 or LIWORK=-1, then the -!> minimal length of IWORK is computed and returned in -!> IWORK(1). See the description of LIWORK. -!> \endverbatim -!..... -!> \param[in] LIWORK -!> \verbatim -!> LIWORK (input) INTEGER -!> The minimal length of the workspace vector IWORK. -!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 -!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) -!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) -!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) -!> If on entry LIWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for both WORK and -!> IWORK. See the descriptions of WORK and IWORK. -!> \endverbatim -!..... -!> \param[out] INFO -!> \verbatim -!> INFO (output) INTEGER -!> -i < 0 :: On entry, the i-th argument had an -!> illegal value -!> = 0 :: Successful return. -!> = 1 :: Void input. Quick exit (M=0 or N=0). -!> = 2 :: The SVD computation of X did not converge. -!> Suggestion: Check the input data and/or -!> repeat with different WHTSVD. -!> = 3 :: The computation of the eigenvalues did not -!> converge. -!> = 4 :: If data scaling was requested on input and -!> the procedure found inconsistency in the data -!> such that for some column index i, -!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set -!> to zero if JOBS=='C'. The computation proceeds -!> with original or modified data and warning -!> flag is set with INFO=4. -!> \endverbatim -! -! Authors: -! ======== -! -!> \author Zlatko Drmac -! -!> \ingroup gedmd -! -!............................................................. -!............................................................. - SUBROUTINE DGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & - M, N, X, LDX, Y, LDY, NRNK, TOL, & - K, REIG, IMEIG, Z, LDZ, RES, & - B, LDB, W, LDW, S, LDS, & - WORK, LWORK, IWORK, LIWORK, INFO ) -! -! -- LAPACK driver routine -- -! -! -- LAPACK is a software package provided by University of -- -! -- Tennessee, University of California Berkeley, University of -- -! -- Colorado Denver and NAG Ltd.. -- -! -!..... - USE iso_fortran_env - IMPLICIT NONE - INTEGER, PARAMETER :: WP = real64 -! -! Scalar arguments -! ~~~~~~~~~~~~~~~~ - CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF - INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & - NRNK, LDZ, LDB, LDW, LDS, & - LWORK, LIWORK - INTEGER, INTENT(OUT) :: K, INFO - REAL(KIND=WP), INTENT(IN) :: TOL -! -! Array arguments -! ~~~~~~~~~~~~~~~ - REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) - REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & - W(LDW,*), S(LDS,*) - REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & - RES(*) - REAL(KIND=WP), INTENT(OUT) :: WORK(*) - INTEGER, INTENT(OUT) :: IWORK(*) -! -! Parameters -! ~~~~~~~~~~ - REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP - REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP -! -! Local scalars -! ~~~~~~~~~~~~~ - REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & - SSUM, XSCL1, XSCL2 - INTEGER :: i, j, IMINWR, INFO1, INFO2, & - LWRKEV, LWRSDD, LWRSVD, & - LWRSVQ, MLWORK, MWRKEV, MWRSDD, & - MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & - OLWORK - LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & - WNTEX, WNTREF, WNTRES, WNTVEC - CHARACTER :: JOBZL, T_OR_N - CHARACTER :: JSVOPT -! -! Local arrays -! ~~~~~~~~~~~~ - REAL(KIND=WP) :: AB(2,2), RDUMMY(2), RDUMMY2(2) -! -! External functions (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~ - REAL(KIND=WP) DLANGE, DLAMCH, DNRM2 - EXTERNAL DLANGE, DLAMCH, DNRM2, IDAMAX - INTEGER IDAMAX - LOGICAL DISNAN, LSAME - EXTERNAL DISNAN, LSAME -! -! External subroutines (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~~~~ - EXTERNAL DAXPY, DGEMM, DSCAL - EXTERNAL DGEEV, DGEJSV, DGESDD, DGESVD, DGESVDQ, & - DLACPY, DLASCL, DLASSQ, XERBLA -! -! Intrinsic functions -! ~~~~~~~~~~~~~~~~~~~ - INTRINSIC DBLE, INT, MAX, SQRT -!............................................................ -! -! Test the input arguments -! - WNTRES = LSAME(JOBR,'R') - SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') - SCCOLY = LSAME(JOBS,'Y') - WNTVEC = LSAME(JOBZ,'V') - WNTREF = LSAME(JOBF,'R') - WNTEX = LSAME(JOBF,'E') - INFO = 0 - LQUERY = ( ( LWORK == -1 ) .OR. ( LIWORK == -1 ) ) -! - IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & - LSAME(JOBS,'N')) ) THEN - INFO = -1 - ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & - .OR. LSAME(JOBZ,'F')) ) THEN - INFO = -2 - ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & - ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN - INFO = -3 - ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & - LSAME(JOBF,'N') ) ) THEN - INFO = -4 - ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & - (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN - INFO = -5 - ELSE IF ( M < 0 ) THEN - INFO = -6 - ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN - INFO = -7 - ELSE IF ( LDX < M ) THEN - INFO = -9 - ELSE IF ( LDY < M ) THEN - INFO = -11 - ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & - ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN - INFO = -12 - ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN - INFO = -13 - ELSE IF ( LDZ < M ) THEN - INFO = -18 - ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN - INFO = -21 - ELSE IF ( LDW < N ) THEN - INFO = -23 - ELSE IF ( LDS < N ) THEN - INFO = -25 - END IF -! - IF ( INFO == 0 ) THEN - ! Compute the minimal and the optimal workspace - ! requirements. Simulate running the code and - ! determine minimal and optimal sizes of the - ! workspace at any moment of the run. - IF ( N == 0 ) THEN - ! Quick return. All output except K is void. - ! INFO=1 signals the void input. - ! In case of a workspace query, the default - ! minimal workspace lengths are returned. - IF ( LQUERY ) THEN - IWORK(1) = 1 - WORK(1) = 2 - WORK(2) = 2 - ELSE - K = 0 - END IF - INFO = 1 - RETURN - END IF - MLWORK = MAX(2,N) - OLWORK = MAX(2,N) - IMINWR = 1 - SELECT CASE ( WHTSVD ) - CASE (1) - ! The following is specified as the minimal - ! length of WORK in the definition of DGESVD: - ! MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - MLWORK = MAX(MLWORK,N + MWRSVD) - IF ( LQUERY ) THEN - CALL DGESVD( 'O', 'S', M, N, X, LDX, WORK, & - B, LDB, W, LDW, RDUMMY, -1, INFO1 ) - LWRSVD = MAX( MWRSVD, INT( RDUMMY(1) ) ) - OLWORK = MAX(OLWORK,N + LWRSVD) - END IF - CASE (2) - ! The following is specified as the minimal - ! length of WORK in the definition of DGESDD: - ! MWRSDD = 3*MIN(M,N)*MIN(M,N) + - ! MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) - ! IMINWR = 8*MIN(M,N) - MWRSDD = 3*MIN(M,N)*MIN(M,N) + & - MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) - MLWORK = MAX(MLWORK,N + MWRSDD) - IMINWR = 8*MIN(M,N) - IF ( LQUERY ) THEN - CALL DGESDD( 'O', M, N, X, LDX, WORK, B, & - LDB, W, LDW, RDUMMY, -1, IWORK, INFO1 ) - LWRSDD = MAX( MWRSDD, INT( RDUMMY(1) ) ) - OLWORK = MAX(OLWORK,N + LWRSDD) - END IF - CASE (3) - !LWQP3 = 3*N+1 - !LWORQ = MAX(N, 1) - !MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - !MWRSVQ = N + MAX( LWQP3, MWRSVD, LWORQ ) + MAX(M,2) - !MLWORK = N + MWRSVQ - !IMINWR = M+N-1 - CALL DGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, WORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, LIWORK, RDUMMY, & - -1, RDUMMY2, -1, INFO1 ) - IMINWR = IWORK(1) - MWRSVQ = INT(RDUMMY(2)) - MLWORK = MAX(MLWORK,N+MWRSVQ+INT(RDUMMY2(1))) - IF ( LQUERY ) THEN - LWRSVQ = MAX( MWRSVQ, INT(RDUMMY(1)) ) - OLWORK = MAX(OLWORK,N+LWRSVQ+INT(RDUMMY2(1))) - END IF - CASE (4) - JSVOPT = 'J' - !MWRSVJ = MAX( 7, 2*M+N, 6*N+2*N*N ) ! for JSVOPT='V' - MWRSVJ = MAX( 7, 2*M+N, 4*N+N*N, 2*N+N*N+6 ) - MLWORK = MAX(MLWORK,N+MWRSVJ) - IMINWR = MAX( 3, M+3*N ) - IF ( LQUERY ) THEN - OLWORK = MAX(OLWORK,N+MWRSVJ) - END IF - END SELECT - IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN - JOBZL = 'V' - ELSE - JOBZL = 'N' - END IF - ! Workspace calculation to the DGEEV call - IF ( LSAME(JOBZL,'V') ) THEN - MWRKEV = MAX( 1, 4*N ) - ELSE - MWRKEV = MAX( 1, 3*N ) - END IF - MLWORK = MAX(MLWORK,N+MWRKEV) - IF ( LQUERY ) THEN - CALL DGEEV( 'N', JOBZL, N, S, LDS, REIG, & - IMEIG, W, LDW, W, LDW, RDUMMY, -1, INFO1 ) - LWRKEV = MAX( MWRKEV, INT(RDUMMY(1)) ) - OLWORK = MAX( OLWORK, N+LWRKEV ) - END IF -! - IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -29 - IF ( LWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -27 - END IF -! - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DGEDMD', -INFO ) - RETURN - ELSE IF ( LQUERY ) THEN -! Return minimal and optimal workspace sizes - IWORK(1) = IMINWR - WORK(1) = MLWORK - WORK(2) = OLWORK - RETURN - END IF -!............................................................ -! - OFL = DLAMCH('O') - SMALL = DLAMCH('S') - BADXY = .FALSE. -! -! <1> Optional scaling of the snapshots (columns of X, Y) -! ========================================================== - IF ( SCCOLX ) THEN - ! The columns of X will be normalized. - ! To prevent overflows, the column norms of X are - ! carefully computed using DLASSQ. - K = 0 - DO i = 1, N - !WORK(i) = DNRM2( M, X(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL DLASSQ( M, X(1,i), 1, SCALE, SSUM ) - IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN - K = 0 - INFO = -8 - CALL XERBLA('DGEDMD',-INFO) - END IF - IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of X(:,i) overflows. First, X(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. -! Next, the norm of X(:,i) is stored without -! overflow as WORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of X(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL DLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, X(1,i), M, INFO2 ) - WORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - WORK(i) = SCALE * ROOTSC - CALL DLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & - X(1,i), M, INFO2 ) ! LAPACK CALL -! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC - END IF - ELSE - WORK(i) = ZERO - K = K + 1 - END IF - END DO - IF ( K == N ) THEN - ! All columns of X are zero. Return error code -8. - ! (the 8th input variable had an illegal value) - K = 0 - INFO = -8 - CALL XERBLA('DGEDMD',-INFO) - RETURN - END IF - DO i = 1, N -! Now, apply the same scaling to the columns of Y. - IF ( WORK(i) > ZERO ) THEN - CALL DSCAL( M, ONE/WORK(i), Y(1,i), 1 ) ! BLAS CALL -! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC - ELSE IF ( WORK(i) < ZERO ) THEN - CALL DLASCL( 'G', 0, 0, -WORK(i), & - ONE/DBLE(M), M, 1, Y(1,i), M, INFO2 ) ! LAPACK CALL - ELSE IF ( Y(IDAMAX(M, Y(1,i),1),i ) & - /= ZERO ) THEN -! X(:,i) is zero vector. For consistency, -! Y(:,i) should also be zero. If Y(:,i) is not -! zero, then the data might be inconsistent or -! corrupted. If JOBS == 'C', Y(:,i) is set to -! zero and a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - IF ( LSAME(JOBS,'C')) & - CALL DSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL - END IF - END DO - END IF - ! - IF ( SCCOLY ) THEN - ! The columns of Y will be normalized. - ! To prevent overflows, the column norms of Y are - ! carefully computed using DLASSQ. - DO i = 1, N - !WORK(i) = DNRM2( M, Y(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL DLASSQ( M, Y(1,i), 1, SCALE, SSUM ) - IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN - K = 0 - INFO = -10 - CALL XERBLA('DGEDMD',-INFO) - END IF - IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of Y(:,i) overflows. First, Y(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. -! Next, the norm of Y(:,i) is stored without -! overflow as WORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of Y(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL DLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, Y(1,i), M, INFO2 ) - WORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - WORK(i) = SCALE * ROOTSC - CALL DLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & - Y(1,i), M, INFO2 ) ! LAPACK CALL -! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC - END IF - ELSE - WORK(i) = ZERO - END IF - END DO - DO i = 1, N -! Now, apply the same scaling to the columns of X. - IF ( WORK(i) > ZERO ) THEN - CALL DSCAL( M, ONE/WORK(i), X(1,i), 1 ) ! BLAS CALL -! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC - ELSE IF ( WORK(i) < ZERO ) THEN - CALL DLASCL( 'G', 0, 0, -WORK(i), & - ONE/DBLE(M), M, 1, X(1,i), M, INFO2 ) ! LAPACK CALL - ELSE IF ( X(IDAMAX(M, X(1,i),1),i ) & - /= ZERO ) THEN -! Y(:,i) is zero vector. If X(:,i) is not -! zero, then a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - END IF - END DO - END IF -! -! <2> SVD of the data snapshot matrix X. -! ===================================== -! The left singular vectors are stored in the array X. -! The right singular vectors are in the array W. -! The array W will later on contain the eigenvectors -! of a Rayleigh quotient. - NUMRNK = N - SELECT CASE ( WHTSVD ) - CASE (1) - CALL DGESVD( 'O', 'S', M, N, X, LDX, WORK, B, & - LDB, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL - T_OR_N = 'T' - CASE (2) - CALL DGESDD( 'O', M, N, X, LDX, WORK, B, LDB, W, & - LDW, WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL - T_OR_N = 'T' - CASE (3) - CALL DGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, WORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, LIWORK, WORK(N+MAX(2,M)+1),& - LWORK-N-MAX(2,M), WORK(N+1), MAX(2,M), INFO1) ! LAPACK CALL - CALL DLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'T' - CASE (4) - CALL DGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & - N, X, LDX, WORK, Z, LDZ, W, LDW, & - WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL - CALL DLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'N' - XSCL1 = WORK(N+1) - XSCL2 = WORK(N+2) - IF ( XSCL1 /= XSCL2 ) THEN - ! This is an exceptional situation. If the - ! data matrices are not scaled and the - ! largest singular value of X overflows. - ! In that case DGEJSV can return the SVD - ! in scaled form. The scaling factor can be used - ! to rescale the data (X and Y). - CALL DLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) - END IF - END SELECT -! - IF ( INFO1 > 0 ) THEN - ! The SVD selected subroutine did not converge. - ! Return with an error code. - INFO = 2 - RETURN - END IF -! - IF ( WORK(1) == ZERO ) THEN - ! The largest computed singular value of (scaled) - ! X is zero. Return error code -8 - ! (the 8th input variable had an illegal value). - K = 0 - INFO = -8 - CALL XERBLA('DGEDMD',-INFO) - RETURN - END IF -! - !<3> Determine the numerical rank of the data - ! snapshots matrix X. This depends on the - ! parameters NRNK and TOL. - - SELECT CASE ( NRNK ) - CASE ( -1 ) - K = 1 - DO i = 2, NUMRNK - IF ( ( WORK(i) <= WORK(1)*TOL ) .OR. & - ( WORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE ( -2 ) - K = 1 - DO i = 1, NUMRNK-1 - IF ( ( WORK(i+1) <= WORK(i)*TOL ) .OR. & - ( WORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE DEFAULT - K = 1 - DO i = 2, NRNK - IF ( WORK(i) <= SMALL ) EXIT - K = K + 1 - END DO - END SELECT - ! Now, U = X(1:M,1:K) is the SVD/POD basis for the - ! snapshot data in the input matrix X. - - !<4> Compute the Rayleigh quotient S = U^T * A * U. - ! Depending on the requested outputs, the computation - ! is organized to compute additional auxiliary - ! matrices (for the residuals and refinements). - ! - ! In all formulas below, we need V_k*Sigma_k^(-1) - ! where either V_k is in W(1:N,1:K), or V_k^T is in - ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). - IF ( LSAME(T_OR_N, 'N') ) THEN - DO i = 1, K - CALL DSCAL( N, ONE/WORK(i), W(1,i), 1 ) ! BLAS CALL - ! W(1:N,i) = (ONE/WORK(i)) * W(1:N,i) ! INTRINSIC - END DO - ELSE - ! This non-unit stride access is due to the fact - ! that DGESVD, DGESVDQ and DGESDD return the - ! transposed matrix of the right singular vectors. - !DO i = 1, K - ! CALL DSCAL( N, ONE/WORK(i), W(i,1), LDW ) ! BLAS CALL - ! ! W(i,1:N) = (ONE/WORK(i)) * W(i,1:N) ! INTRINSIC - !END DO - DO i = 1, K - WORK(N+i) = ONE/WORK(i) - END DO - DO j = 1, N - DO i = 1, K - W(i,j) = (WORK(N+i))*W(i,j) - END DO - END DO - END IF -! - IF ( WNTREF ) THEN - ! - ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) - ! for computing the refined Ritz vectors - ! (optionally, outside DGEDMD). - CALL DGEMM( 'N', T_OR_N, M, K, N, ONE, Y, LDY, W, & - LDW, ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' - ! - ! At this point Z contains - ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and - ! this is needed for computing the residuals. - ! This matrix is returned in the array B and - ! it can be used to compute refined Ritz vectors. - CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL - ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC - - CALL DGEMM( 'T', 'N', K, K, M, ONE, X, LDX, Z, & - LDZ, ZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC - ! At this point S = U^T * A * U is the Rayleigh quotient. - ELSE - ! A * U(:,1:K) is not explicitly needed and the - ! computation is organized differently. The Rayleigh - ! quotient is computed more efficiently. - CALL DGEMM( 'T', 'N', K, N, M, ONE, X, LDX, Y, LDY, & - ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC - ! In the two DGEMM calls here, can use K for LDZ. - CALL DGEMM( 'N', T_OR_N, K, K, N, ONE, Z, LDZ, W, & - LDW, ZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' - ! At this point S = U^T * A * U is the Rayleigh quotient. - ! If the residuals are requested, save scaled V_k into Z. - ! Recall that V_k or V_k^T is stored in W. - IF ( WNTRES .OR. WNTEX ) THEN - IF ( LSAME(T_OR_N, 'N') ) THEN - CALL DLACPY( 'A', N, K, W, LDW, Z, LDZ ) - ELSE - CALL DLACPY( 'A', K, N, W, LDW, Z, LDZ ) - END IF - END IF - END IF -! - !<5> Compute the Ritz values and (if requested) the - ! right eigenvectors of the Rayleigh quotient. - ! - CALL DGEEV( 'N', JOBZL, K, S, LDS, REIG, IMEIG, W, & - LDW, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL - ! - ! W(1:K,1:K) contains the eigenvectors of the Rayleigh - ! quotient. Even in the case of complex spectrum, all - ! computation is done in real arithmetic. REIG and - ! IMEIG are the real and the imaginary parts of the - ! eigenvalues, so that the spectrum is given as - ! REIG(:) + sqrt(-1)*IMEIG(:). Complex conjugate pairs - ! are listed at consecutive positions. For such a - ! complex conjugate pair of the eigenvalues, the - ! corresponding eigenvectors are also a complex - ! conjugate pair with the real and imaginary parts - ! stored column-wise in W at the corresponding - ! consecutive column indices. See the description of Z. - ! Also, see the description of DGEEV. - IF ( INFO1 > 0 ) THEN - ! DGEEV failed to compute the eigenvalues and - ! eigenvectors of the Rayleigh quotient. - INFO = 3 - RETURN - END IF -! - ! <6> Compute the eigenvectors (if requested) and, - ! the residuals (if requested). - ! - IF ( WNTVEC .OR. WNTEX ) THEN - IF ( WNTRES ) THEN - IF ( WNTREF ) THEN - ! Here, if the refinement is requested, we have - ! A*U(:,1:K) already computed and stored in Z. - ! For the residuals, need Y = A * U(:,1;K) * W. - CALL DGEMM( 'N', 'N', M, K, K, ONE, Z, LDZ, W, & - LDW, ZERO, Y, LDY ) ! BLAS CALL - ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC - ! This frees Z; Y contains A * U(:,1:K) * W. - ELSE - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL DGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & - W, LDW, ZERO, S, LDS) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - LDS, ZERO, Z, LDZ) - ! Save a copy of Z into Y and free Z for holding - ! the Ritz vectors. - CALL DLACPY( 'A', M, K, Z, LDZ, Y, LDY ) - IF ( WNTEX ) CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF - ELSE IF ( WNTEX ) THEN - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL DGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & - W, LDW, ZERO, S, LDS ) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - LDS, ZERO, B, LDB ) - ! The above call replaces the following two calls - ! that were used in the developing-testing phase. - ! CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - ! LDS, ZERO, Z, LDZ) - ! Save a copy of Z into B and free Z for holding - ! the Ritz vectors. - ! CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF -! - ! Compute the real form of the Ritz vectors - IF ( WNTVEC ) CALL DGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & - ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC -! - IF ( WNTRES ) THEN - i = 1 - DO WHILE ( i <= K ) - IF ( IMEIG(i) == ZERO ) THEN - ! have a real eigenvalue with real eigenvector - CALL DAXPY( M, -REIG(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL - ! Y(1:M,i) = Y(1:M,i) - REIG(i) * Z(1:M,i) ! INTRINSIC - RES(i) = DNRM2( M, Y(1,i), 1) ! BLAS CALL - i = i + 1 - ELSE - ! Have a complex conjugate pair - ! REIG(i) +- sqrt(-1)*IMEIG(i). - ! Since all computation is done in real - ! arithmetic, the formula for the residual - ! is recast for real representation of the - ! complex conjugate eigenpair. See the - ! description of RES. - AB(1,1) = REIG(i) - AB(2,1) = -IMEIG(i) - AB(1,2) = IMEIG(i) - AB(2,2) = REIG(i) - CALL DGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & - LDZ, AB, 2, ONE, Y(1,i), LDY ) ! BLAS CALL - ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC - RES(i) = DLANGE( 'F', M, 2, Y(1,i), LDY, & - WORK(N+1) ) ! LAPACK CALL - RES(i+1) = RES(i) - i = i + 2 - END IF - END DO - END IF - END IF -! - IF ( WHTSVD == 4 ) THEN - WORK(N+1) = XSCL1 - WORK(N+2) = XSCL2 - END IF -! -! Successful exit. - IF ( .NOT. BADXY ) THEN - INFO = 0 - ELSE - ! A warning on possible data inconsistency. - ! This should be a rare event. - INFO = 4 - END IF -!............................................................ - RETURN -! ...... - END SUBROUTINE DGEDMD +!> \brief \b DGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. +! +! =========== DOCUMENTATION =========== +! +! Definition: +! =========== +! +! SUBROUTINE DGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & +! M, N, X, LDX, Y, LDY, NRNK, TOL, & +! K, REIG, IMEIG, Z, LDZ, RES, & +! B, LDB, W, LDW, S, LDS, & +! WORK, LWORK, IWORK, LIWORK, INFO ) +!..... +! USE, INTRINSIC :: iso_fortran_env, only: real64 +! IMPLICIT NONE +! INTEGER, PARAMETER :: WP = real64 +!..... +! Scalar arguments +! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF +! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & +! NRNK, LDZ, LDB, LDW, LDS, & +! LWORK, LIWORK +! INTEGER, INTENT(OUT) :: K, INFO +! REAL(KIND=WP), INTENT(IN) :: TOL +! Array arguments +! REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) +! REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & +! W(LDW,*), S(LDS,*) +! REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & +! RES(*) +! REAL(KIND=WP), INTENT(OUT) :: WORK(*) +! INTEGER, INTENT(OUT) :: IWORK(*) +! +!............................................................ +!> \par Purpose: +! ============= +!> \verbatim +!> DGEDMD computes the Dynamic Mode Decomposition (DMD) for +!> a pair of data snapshot matrices. For the input matrices +!> X and Y such that Y = A*X with an unaccessible matrix +!> A, DGEDMD computes a certain number of Ritz pairs of A using +!> the standard Rayleigh-Ritz extraction from a subspace of +!> range(X) that is determined using the leading left singular +!> vectors of X. Optionally, DGEDMD returns the residuals +!> of the computed Ritz pairs, the information needed for +!> a refinement of the Ritz vectors, or the eigenvectors of +!> the Exact DMD. +!> For further details see the references listed +!> below. For more details of the implementation see [3]. +!> \endverbatim +!............................................................ +!> \par References: +! ================ +!> \verbatim +!> [1] P. Schmid: Dynamic mode decomposition of numerical +!> and experimental data, +!> Journal of Fluid Mechanics 656, 5-28, 2010. +!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal +!> decompositions: analysis and enhancements, +!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. +!> [3] Z. Drmac: A LAPACK implementation of the Dynamic +!> Mode Decomposition I. Technical report. AIMDyn Inc. +!> and LAPACK Working Note 298. +!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. +!> Brunton, N. Kutz: On Dynamic Mode Decomposition: +!> Theory and Applications, Journal of Computational +!> Dynamics 1(2), 391 -421, 2014. +!> \endverbatim +!...................................................................... +!> \par Developed and supported by: +! ================================ +!> \verbatim +!> Developed and coded by Zlatko Drmac, Faculty of Science, +!> University of Zagreb; drmac@math.hr +!> In cooperation with +!> AIMdyn Inc., Santa Barbara, CA. +!> and supported by +!> - DARPA SBIR project "Koopman Operator-Based Forecasting +!> for Nonstationary Processes from Near-Term, Limited +!> Observational Data" Contract No: W31P4Q-21-C-0007 +!> - DARPA PAI project "Physics-Informed Machine Learning +!> Methodologies" Contract No: HR0011-18-9-0033 +!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic +!> Framework for Space-Time Analysis of Process Dynamics" +!> Contract No: HR0011-16-C-0116 +!> Any opinions, findings and conclusions or recommendations +!> expressed in this material are those of the author and +!> do not necessarily reflect the views of the DARPA SBIR +!> Program Office +!> \endverbatim +!...................................................................... +!> \par Distribution Statement A: +! ============================== +!> \verbatim +!> Approved for Public Release, Distribution Unlimited. +!> Cleared by DARPA on September 29, 2022 +!> \endverbatim +!...................................................................... +! Arguments +! ========= +! +!> \param[in] JOBS +!> \verbatim +!> JOBS (input) is CHARACTER*1 +!> Determines whether the initial data snapshots are scaled +!> by a diagonal matrix. +!> 'S' :: The data snapshots matrices X and Y are multiplied +!> with a diagonal matrix D so that X*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'C' :: The snapshots are scaled as with the 'S' option. +!> If it is found that an i-th column of X is zero +!> vector and the corresponding i-th column of Y is +!> non-zero, then the i-th column of Y is set to +!> zero and a warning flag is raised. +!> 'Y' :: The data snapshots matrices X and Y are multiplied +!> by a diagonal matrix D so that Y*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'N' :: No data scaling. +!> \endverbatim +!..... +!> \param[in] JOBZ +!> \verbatim +!> JOBZ (input) CHARACTER*1 +!> Determines whether the eigenvectors (Koopman modes) will +!> be computed. +!> 'V' :: The eigenvectors (Koopman modes) will be computed +!> and returned in the matrix Z. +!> See the description of Z. +!> 'F' :: The eigenvectors (Koopman modes) will be returned +!> in factored form as the product X(:,1:K)*W, where X +!> contains a POD basis (leading left singular vectors +!> of the data matrix X) and W contains the eigenvectors +!> of the corresponding Rayleigh quotient. +!> See the descriptions of K, X, W, Z. +!> 'N' :: The eigenvectors are not computed. +!> \endverbatim +!..... +!> \param[in] JOBR +!> \verbatim +!> JOBR (input) CHARACTER*1 +!> Determines whether to compute the residuals. +!> 'R' :: The residuals for the computed eigenpairs will be +!> computed and stored in the array RES. +!> See the description of RES. +!> For this option to be legal, JOBZ must be 'V'. +!> 'N' :: The residuals are not computed. +!> \endverbatim +!..... +!> \param[in] JOBF +!> \verbatim +!> JOBF (input) CHARACTER*1 +!> Specifies whether to store information needed for post- +!> processing (e.g. computing refined Ritz vectors) +!> 'R' :: The matrix needed for the refinement of the Ritz +!> vectors is computed and stored in the array B. +!> See the description of B. +!> 'E' :: The unscaled eigenvectors of the Exact DMD are +!> computed and returned in the array B. See the +!> description of B. +!> 'N' :: No eigenvector refinement data is computed. +!> \endverbatim +!..... +!> \param[in] WHTSVD +!> \verbatim +!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } +!> Allows for a selection of the SVD algorithm from the +!> LAPACK library. +!> 1 :: DGESVD (the QR SVD algorithm) +!> 2 :: DGESDD (the Divide and Conquer algorithm; if enough +!> workspace available, this is the fastest option) +!> 3 :: DGESVDQ (the preconditioned QR SVD ; this and 4 +!> are the most accurate options) +!> 4 :: DGEJSV (the preconditioned Jacobi SVD; this and 3 +!> are the most accurate options) +!> For the four methods above, a significant difference in +!> the accuracy of small singular values is possible if +!> the snapshots vary in norm so that X is severely +!> ill-conditioned. If small (smaller than EPS*||X||) +!> singular values are of interest and JOBS=='N', then +!> the options (3, 4) give the most accurate results, where +!> the option 4 is slightly better and with stronger +!> theoretical background. +!> If JOBS=='S', i.e. the columns of X will be normalized, +!> then all methods give nearly equally accurate results. +!> \endverbatim +!..... +!> \param[in] M +!> \verbatim +!> M (input) INTEGER, M>= 0 +!> The state space dimension (the row dimension of X, Y). +!> \endverbatim +!..... +!> \param[in] N +!> \verbatim +!> N (input) INTEGER, 0 <= N <= M +!> The number of data snapshot pairs +!> (the number of columns of X and Y). +!> \endverbatim +!..... +!> \param[in,out] X +!> \verbatim +!> X (input/output) REAL(KIND=WP) M-by-N array +!> > On entry, X contains the data snapshot matrix X. It is +!> assumed that the column norms of X are in the range of +!> the normalized floating point numbers. +!> < On exit, the leading K columns of X contain a POD basis, +!> i.e. the leading K left singular vectors of the input +!> data matrix X, U(:,1:K). All N columns of X contain all +!> left singular vectors of the input matrix X. +!> See the descriptions of K, Z and W. +!> \endverbatim +!..... +!> \param[in] LDX +!> \verbatim +!> LDX (input) INTEGER, LDX >= M +!> The leading dimension of the array X. +!> \endverbatim +!..... +!> \param[in,out] Y +!> \verbatim +!> Y (input/workspace/output) REAL(KIND=WP) M-by-N array +!> > On entry, Y contains the data snapshot matrix Y +!> < On exit, +!> If JOBR == 'R', the leading K columns of Y contain +!> the residual vectors for the computed Ritz pairs. +!> See the description of RES. +!> If JOBR == 'N', Y contains the original input data, +!> scaled according to the value of JOBS. +!> \endverbatim +!..... +!> \param[in] LDY +!> \verbatim +!> LDY (input) INTEGER , LDY >= M +!> The leading dimension of the array Y. +!> \endverbatim +!..... +!> \param[in] NRNK +!> \verbatim +!> NRNK (input) INTEGER +!> Determines the mode how to compute the numerical rank, +!> i.e. how to truncate small singular values of the input +!> matrix X. On input, if +!> NRNK = -1 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(1). +!> This option is recommended. +!> NRNK = -2 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(i-1) +!> This option is included for R&D purposes. +!> It requires highly accurate SVD, which +!> may not be feasible. +!> +!> The numerical rank can be enforced by using positive +!> value of NRNK as follows: +!> 0 < NRNK <= N :: at most NRNK largest singular values +!> will be used. If the number of the computed nonzero +!> singular values is less than NRNK, then only those +!> nonzero values will be used and the actually used +!> dimension is less than NRNK. The actual number of +!> the nonzero singular values is returned in the variable +!> K. See the descriptions of TOL and K. +!> \endverbatim +!..... +!> \param[in] TOL +!> \verbatim +!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 +!> The tolerance for truncating small singular values. +!> See the description of NRNK. +!> \endverbatim +!..... +!> \param[out] K +!> \verbatim +!> K (output) INTEGER, 0 <= K <= N +!> The dimension of the POD basis for the data snapshot +!> matrix X and the number of the computed Ritz pairs. +!> The value of K is determined according to the rule set +!> by the parameters NRNK and TOL. +!> See the descriptions of NRNK and TOL. +!> \endverbatim +!..... +!> \param[out] REIG +!> \verbatim +!> REIG (output) REAL(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of REIG contain +!> the real parts of the computed eigenvalues +!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). +!> See the descriptions of K, IMEIG, and Z. +!> \endverbatim +!..... +!> \param[out] IMEIG +!> \verbatim +!> IMEIG (output) REAL(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of IMEIG contain +!> the imaginary parts of the computed eigenvalues +!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). +!> The eigenvalues are determined as follows: +!> If IMEIG(i) == 0, then the corresponding eigenvalue is +!> real, LAMBDA(i) = REIG(i). +!> If IMEIG(i)>0, then the corresponding complex +!> conjugate pair of eigenvalues reads +!> LAMBDA(i) = REIG(i) + sqrt(-1)*IMAG(i) +!> LAMBDA(i+1) = REIG(i) - sqrt(-1)*IMAG(i) +!> That is, complex conjugate pairs have consecutive +!> indices (i,i+1), with the positive imaginary part +!> listed first. +!> See the descriptions of K, REIG, and Z. +!> \endverbatim +!..... +!> \param[out] Z +!> \verbatim +!> Z (workspace/output) REAL(KIND=WP) M-by-N array +!> If JOBZ =='V' then +!> Z contains real Ritz vectors as follows: +!> If IMEIG(i)=0, then Z(:,i) is an eigenvector of +!> the i-th Ritz value; ||Z(:,i)||_2=1. +!> If IMEIG(i) > 0 (and IMEIG(i+1) < 0) then +!> [Z(:,i) Z(:,i+1)] span an invariant subspace and +!> the Ritz values extracted from this subspace are +!> REIG(i) + sqrt(-1)*IMEIG(i) and +!> REIG(i) - sqrt(-1)*IMEIG(i). +!> The corresponding eigenvectors are +!> Z(:,i) + sqrt(-1)*Z(:,i+1) and +!> Z(:,i) - sqrt(-1)*Z(:,i+1), respectively. +!> || Z(:,i:i+1)||_F = 1. +!> If JOBZ == 'F', then the above descriptions hold for +!> the columns of X(:,1:K)*W(1:K,1:K), where the columns +!> of W(1:k,1:K) are the computed eigenvectors of the +!> K-by-K Rayleigh quotient. The columns of W(1:K,1:K) +!> are similarly structured: If IMEIG(i) == 0 then +!> X(:,1:K)*W(:,i) is an eigenvector, and if IMEIG(i)>0 +!> then X(:,1:K)*W(:,i)+sqrt(-1)*X(:,1:K)*W(:,i+1) and +!> X(:,1:K)*W(:,i)-sqrt(-1)*X(:,1:K)*W(:,i+1) +!> are the eigenvectors of LAMBDA(i), LAMBDA(i+1). +!> See the descriptions of REIG, IMEIG, X and W. +!> \endverbatim +!..... +!> \param[in] LDZ +!> \verbatim +!> LDZ (input) INTEGER , LDZ >= M +!> The leading dimension of the array Z. +!> \endverbatim +!..... +!> \param[out] RES +!> \verbatim +!> RES (output) REAL(KIND=WP) N-by-1 array +!> RES(1:K) contains the residuals for the K computed +!> Ritz pairs. +!> If LAMBDA(i) is real, then +!> RES(i) = || A * Z(:,i) - LAMBDA(i)*Z(:,i))||_2. +!> If [LAMBDA(i), LAMBDA(i+1)] is a complex conjugate pair +!> then +!> RES(i)=RES(i+1) = || A * Z(:,i:i+1) - Z(:,i:i+1) *B||_F +!> where B = [ real(LAMBDA(i)) imag(LAMBDA(i)) ] +!> [-imag(LAMBDA(i)) real(LAMBDA(i)) ]. +!> It holds that +!> RES(i) = || A*ZC(:,i) - LAMBDA(i) *ZC(:,i) ||_2 +!> RES(i+1) = || A*ZC(:,i+1) - LAMBDA(i+1)*ZC(:,i+1) ||_2 +!> where ZC(:,i) = Z(:,i) + sqrt(-1)*Z(:,i+1) +!> ZC(:,i+1) = Z(:,i) - sqrt(-1)*Z(:,i+1) +!> See the description of REIG, IMEIG and Z. +!> \endverbatim +!..... +!> \param[out] B +!> \verbatim +!> B (output) REAL(KIND=WP) M-by-N array. +!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can +!> be used for computing the refined vectors; see further +!> details in the provided references. +!> If JOBF == 'E', B(1:M,1;K) contains +!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the +!> Exact DMD, up to scaling by the inverse eigenvalues. +!> If JOBF =='N', then B is not referenced. +!> See the descriptions of X, W, K. +!> \endverbatim +!..... +!> \param[in] LDB +!> \verbatim +!> LDB (input) INTEGER, LDB >= M +!> The leading dimension of the array B. +!> \endverbatim +!..... +!> \param[out] W +!> \verbatim +!> W (workspace/output) REAL(KIND=WP) N-by-N array +!> On exit, W(1:K,1:K) contains the K computed +!> eigenvectors of the matrix Rayleigh quotient (real and +!> imaginary parts for each complex conjugate pair of the +!> eigenvalues). The Ritz vectors (returned in Z) are the +!> product of X (containing a POD basis for the input +!> matrix X) and W. See the descriptions of K, S, X and Z. +!> W is also used as a workspace to temporarily store the +!> right singular vectors of X. +!> \endverbatim +!..... +!> \param[in] LDW +!> \verbatim +!> LDW (input) INTEGER, LDW >= N +!> The leading dimension of the array W. +!> \endverbatim +!..... +!> \param[out] S +!> \verbatim +!> S (workspace/output) REAL(KIND=WP) N-by-N array +!> The array S(1:K,1:K) is used for the matrix Rayleigh +!> quotient. This content is overwritten during +!> the eigenvalue decomposition by DGEEV. +!> See the description of K. +!> \endverbatim +!..... +!> \param[in] LDS +!> \verbatim +!> LDS (input) INTEGER, LDS >= N +!> The leading dimension of the array S. +!> \endverbatim +!..... +!> \param[out] WORK +!> \verbatim +!> WORK (workspace/output) REAL(KIND=WP) LWORK-by-1 array +!> On exit, WORK(1:N) contains the singular values of +!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). +!> If WHTSVD==4, then WORK(N+1) and WORK(N+2) contain +!> scaling factor WORK(N+2)/WORK(N+1) used to scale X +!> and Y to avoid overflow in the SVD of X. +!> This may be of interest if the scaling option is off +!> and as many as possible smallest eigenvalues are +!> desired to the highest feasible accuracy. +!> If the call to DGEDMD is only workspace query, then +!> WORK(1) contains the minimal workspace length and +!> WORK(2) is the optimal workspace length. Hence, the +!> leng of work is at least 2. +!> See the description of LWORK. +!> \endverbatim +!..... +!> \param[in] LWORK +!> \verbatim +!> LWORK (input) INTEGER +!> The minimal length of the workspace vector WORK. +!> LWORK is calculated as follows: +!> If WHTSVD == 1 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)). +!> If JOBZ == 'N' then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)). +!> Here LWORK_SVD = MAX(1,3*N+M,5*N) is the minimal +!> workspace length of DGESVD. +!> If WHTSVD == 2 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)) +!> Here LWORK_SVD = MAX(M, 5*N*N+4*N)+3*N*N is the +!> minimal workspace length of DGESDD. +!> If WHTSVD == 3 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) +!> Here LWORK_SVD = N+M+MAX(3*N+1, +!> MAX(1,3*N+M,5*N),MAX(1,N)) +!> is the minimal workspace length of DGESVDQ. +!> If WHTSVD == 4 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) +!> Here LWORK_SVD = MAX(7,2*M+N,6*N+2*N*N) is the +!> minimal workspace length of DGEJSV. +!> The above expressions are not simplified in order to +!> make the usage of WORK more transparent, and for +!> easier checking. In any case, LWORK >= 2. +!> If on entry LWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for both WORK and +!> IWORK. See the descriptions of WORK and IWORK. +!> \endverbatim +!..... +!> \param[out] IWORK +!> \verbatim +!> IWORK (workspace/output) INTEGER LIWORK-by-1 array +!> Workspace that is required only if WHTSVD equals +!> 2 , 3 or 4. (See the description of WHTSVD). +!> If on entry LWORK =-1 or LIWORK=-1, then the +!> minimal length of IWORK is computed and returned in +!> IWORK(1). See the description of LIWORK. +!> \endverbatim +!..... +!> \param[in] LIWORK +!> \verbatim +!> LIWORK (input) INTEGER +!> The minimal length of the workspace vector IWORK. +!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 +!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) +!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) +!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) +!> If on entry LIWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for both WORK and +!> IWORK. See the descriptions of WORK and IWORK. +!> \endverbatim +!..... +!> \param[out] INFO +!> \verbatim +!> INFO (output) INTEGER +!> -i < 0 :: On entry, the i-th argument had an +!> illegal value +!> = 0 :: Successful return. +!> = 1 :: Void input. Quick exit (M=0 or N=0). +!> = 2 :: The SVD computation of X did not converge. +!> Suggestion: Check the input data and/or +!> repeat with different WHTSVD. +!> = 3 :: The computation of the eigenvalues did not +!> converge. +!> = 4 :: If data scaling was requested on input and +!> the procedure found inconsistency in the data +!> such that for some column index i, +!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set +!> to zero if JOBS=='C'. The computation proceeds +!> with original or modified data and warning +!> flag is set with INFO=4. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Zlatko Drmac +! +!> \ingroup gedmd +! +!............................................................. +!............................................................. + SUBROUTINE DGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, REIG, IMEIG, Z, LDZ, RES, & + B, LDB, W, LDW, S, LDS, & + WORK, LWORK, IWORK, LIWORK, INFO ) +! +! -- LAPACK driver routine -- +! +! -- LAPACK is a software package provided by University of -- +! -- Tennessee, University of California Berkeley, University of -- +! -- Colorado Denver and NAG Ltd.. -- +! +!..... + USE, INTRINSIC :: iso_fortran_env, only: real64 + IMPLICIT NONE + INTEGER, PARAMETER :: WP = real64 +! +! Scalar arguments +! ~~~~~~~~~~~~~~~~ + CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF + INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & + NRNK, LDZ, LDB, LDW, LDS, & + LWORK, LIWORK + INTEGER, INTENT(OUT) :: K, INFO + REAL(KIND=WP), INTENT(IN) :: TOL +! +! Array arguments +! ~~~~~~~~~~~~~~~ + REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) + REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & + W(LDW,*), S(LDS,*) + REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & + RES(*) + REAL(KIND=WP), INTENT(OUT) :: WORK(*) + INTEGER, INTENT(OUT) :: IWORK(*) +! +! Parameters +! ~~~~~~~~~~ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP +! +! Local scalars +! ~~~~~~~~~~~~~ + REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & + SSUM, XSCL1, XSCL2, TBIG + INTEGER :: i, j, IMINWR, INFO1, INFO2, & + LWRKEV, LWRSDD, LWRSVD, & + LWRSVQ, MLWORK, MWRKEV, MWRSDD, & + MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & + OLWORK + LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & + WNTEX, WNTREF, WNTRES, WNTVEC + CHARACTER :: JOBZL, T_OR_N + CHARACTER :: JSVOPT +! +! Local arrays +! ~~~~~~~~~~~~ + REAL(KIND=WP) :: AB(2,2), RDUMMY(2), RDUMMY2(2) +! +! External functions (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~ + REAL(KIND=WP) DLANGE, DLAMCH, DNRM2 + EXTERNAL DLANGE, DLAMCH, DNRM2, IDAMAX + INTEGER IDAMAX + LOGICAL DISNAN, LSAME + EXTERNAL DISNAN, LSAME +! +! External subroutines (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~~~~ + EXTERNAL DAXPY, DGEMM, DSCAL + EXTERNAL DGEEV, DGEJSV, DGESDD, DGESVD, DGESVDQ, & + DLACPY, DLASCL, DLASSQ, XERBLA +! +! Intrinsic functions +! ~~~~~~~~~~~~~~~~~~~ + INTRINSIC DBLE, INT, MAX, SQRT +!............................................................ +! +! Test the input arguments +! + WNTRES = LSAME(JOBR,'R') + SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') + SCCOLY = LSAME(JOBS,'Y') + WNTVEC = LSAME(JOBZ,'V') + WNTREF = LSAME(JOBF,'R') + WNTEX = LSAME(JOBF,'E') + INFO = 0 + LQUERY = ( ( LWORK == -1 ) .OR. ( LIWORK == -1 ) ) +! + IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & + LSAME(JOBS,'N')) ) THEN + INFO = -1 + ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & + .OR. LSAME(JOBZ,'F')) ) THEN + INFO = -2 + ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & + ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN + INFO = -3 + ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & + LSAME(JOBF,'N') ) ) THEN + INFO = -4 + ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & + (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN + INFO = -5 + ELSE IF ( M < 0 ) THEN + INFO = -6 + ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN + INFO = -7 + ELSE IF ( LDX < M ) THEN + INFO = -9 + ELSE IF ( LDY < M ) THEN + INFO = -11 + ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & + ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN + INFO = -12 + ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN + INFO = -13 + ELSE IF ( LDZ < M ) THEN + INFO = -18 + ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN + INFO = -21 + ELSE IF ( LDW < N ) THEN + INFO = -23 + ELSE IF ( LDS < N ) THEN + INFO = -25 + END IF +! + IF ( INFO == 0 ) THEN + ! Compute the minimal and the optimal workspace + ! requirements. Simulate running the code and + ! determine minimal and optimal sizes of the + ! workspace at any moment of the run. + IF ( N == 0 ) THEN + ! Quick return. All output except K is void. + ! INFO=1 signals the void input. + ! In case of a workspace query, the default + ! minimal workspace lengths are returned. + IF ( LQUERY ) THEN + IWORK(1) = 1 + WORK(1) = 2 + WORK(2) = 2 + ELSE + K = 0 + END IF + INFO = 1 + RETURN + END IF + MLWORK = MAX(2,N) + OLWORK = MAX(2,N) + IMINWR = 1 + SELECT CASE ( WHTSVD ) + CASE (1) + ! The following is specified as the minimal + ! length of WORK in the definition of DGESVD: + ! MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + MLWORK = MAX(MLWORK,N + MWRSVD) + IF ( LQUERY ) THEN + CALL DGESVD( 'O', 'S', M, N, X, LDX, WORK, & + B, LDB, W, LDW, RDUMMY, -1, INFO1 ) + LWRSVD = MAX( MWRSVD, INT( RDUMMY(1) ) ) + OLWORK = MAX(OLWORK,N + LWRSVD) + END IF + CASE (2) + ! The following is specified as the minimal + ! length of WORK in the definition of DGESDD: + ! MWRSDD = 3*MIN(M,N)*MIN(M,N) + + ! MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) + ! IMINWR = 8*MIN(M,N) + MWRSDD = 3*MIN(M,N)*MIN(M,N) + & + MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) + MLWORK = MAX(MLWORK,N + MWRSDD) + IMINWR = 8*MIN(M,N) + IF ( LQUERY ) THEN + CALL DGESDD( 'O', M, N, X, LDX, WORK, B, & + LDB, W, LDW, RDUMMY, -1, IWORK, INFO1 ) + LWRSDD = MAX( MWRSDD, INT( RDUMMY(1) ) ) + OLWORK = MAX(OLWORK,N + LWRSDD) + END IF + CASE (3) + !LWQP3 = 3*N+1 + !LWORQ = MAX(N, 1) + !MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + !MWRSVQ = N + MAX( LWQP3, MWRSVD, LWORQ ) + MAX(M,2) + !MLWORK = N + MWRSVQ + !IMINWR = M+N-1 + CALL DGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, WORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, LIWORK, RDUMMY, & + -1, RDUMMY2, -1, INFO1 ) + IMINWR = IWORK(1) + MWRSVQ = INT(RDUMMY(2)) + MLWORK = MAX(MLWORK,N+MWRSVQ+INT(RDUMMY2(1))) + IF ( LQUERY ) THEN + LWRSVQ = MAX( MWRSVQ, INT(RDUMMY(1)) ) + OLWORK = MAX(OLWORK,N+LWRSVQ+INT(RDUMMY2(1))) + END IF + CASE (4) + JSVOPT = 'J' + !MWRSVJ = MAX( 7, 2*M+N, 6*N+2*N*N ) ! for JSVOPT='V' + MWRSVJ = MAX( 7, 2*M+N, 4*N+N*N, 2*N+N*N+6 ) + MLWORK = MAX(MLWORK,N+MWRSVJ) + IMINWR = MAX( 3, M+3*N ) + IF ( LQUERY ) THEN + OLWORK = MAX(OLWORK,N+MWRSVJ) + END IF + END SELECT + IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN + JOBZL = 'V' + ELSE + JOBZL = 'N' + END IF + ! Workspace calculation to the DGEEV call + IF ( LSAME(JOBZL,'V') ) THEN + MWRKEV = MAX( 1, 4*N ) + ELSE + MWRKEV = MAX( 1, 3*N ) + END IF + MLWORK = MAX(MLWORK,N+MWRKEV) + IF ( LQUERY ) THEN + CALL DGEEV( 'N', JOBZL, N, S, LDS, REIG, & + IMEIG, W, LDW, W, LDW, RDUMMY, -1, INFO1 ) + LWRKEV = MAX( MWRKEV, INT(RDUMMY(1)) ) + OLWORK = MAX( OLWORK, N+LWRKEV ) + END IF +! + IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -29 + IF ( LWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -27 + END IF +! + IF( INFO /= 0 ) THEN + CALL XERBLA( 'DGEDMD', -INFO ) + RETURN + ELSE IF ( LQUERY ) THEN +! Return minimal and optimal workspace sizes + IWORK(1) = IMINWR + WORK(1) = MLWORK + WORK(2) = OLWORK + RETURN + END IF +!............................................................ +! + OFL = DLAMCH('O') + SMALL = DLAMCH('S') + BADXY = .FALSE. +! +! <1> Optional scaling of the snapshots (columns of X, Y) +! ========================================================== + IF ( SCCOLX ) THEN + ! The columns of X will be normalized. + ! To prevent overflows, the column norms of X are + ! carefully computed using DLASSQ. + K = 0 + DO i = 1, N + !WORK(i) = DNRM2( M, X(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL DLASSQ( M, X(1,i), 1, SCALE, SSUM ) + IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN + K = 0 + INFO = -8 + CALL XERBLA('DGEDMD',-INFO) + END IF + IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of X(:,i) overflows. First, X(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. +! Next, the norm of X(:,i) is stored without +! overflow as WORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of X(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL DLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, X(1,i), M, INFO2 ) + WORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + WORK(i) = SCALE * ROOTSC + CALL DLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & + X(1,i), M, INFO2 ) ! LAPACK CALL +! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC + END IF + ELSE + WORK(i) = ZERO + K = K + 1 + END IF + END DO + IF ( K == N ) THEN + ! All columns of X are zero. Return error code -8. + ! (the 8th input variable had an illegal value) + K = 0 + INFO = -8 + CALL XERBLA('DGEDMD',-INFO) + RETURN + END IF + DO i = 1, N +! Now, apply the same scaling to the columns of Y. + IF ( WORK(i) > ZERO ) THEN + CALL DSCAL( M, ONE/WORK(i), Y(1,i), 1 ) ! BLAS CALL +! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC + ELSE IF ( WORK(i) < ZERO ) THEN + CALL DLASCL( 'G', 0, 0, -WORK(i), & + ONE/DBLE(M), M, 1, Y(1,i), M, INFO2 ) ! LAPACK CALL + ELSE IF ( Y(IDAMAX(M, Y(1,i),1),i ) & + /= ZERO ) THEN +! X(:,i) is zero vector. For consistency, +! Y(:,i) should also be zero. If Y(:,i) is not +! zero, then the data might be inconsistent or +! corrupted. If JOBS == 'C', Y(:,i) is set to +! zero and a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + IF ( LSAME(JOBS,'C')) & + CALL DSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL + END IF + END DO + END IF + ! + IF ( SCCOLY ) THEN + ! The columns of Y will be normalized. + ! To prevent overflows, the column norms of Y are + ! carefully computed using DLASSQ. + DO i = 1, N + !WORK(i) = DNRM2( M, Y(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL DLASSQ( M, Y(1,i), 1, SCALE, SSUM ) + IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN + K = 0 + INFO = -10 + CALL XERBLA('DGEDMD',-INFO) + END IF + IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of Y(:,i) overflows. First, Y(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. +! Next, the norm of Y(:,i) is stored without +! overflow as WORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of Y(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL DLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, Y(1,i), M, INFO2 ) + WORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + WORK(i) = SCALE * ROOTSC + CALL DLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & + Y(1,i), M, INFO2 ) ! LAPACK CALL +! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC + END IF + ELSE + WORK(i) = ZERO + END IF + END DO + DO i = 1, N +! Now, apply the same scaling to the columns of X. + IF ( WORK(i) > ZERO ) THEN + CALL DSCAL( M, ONE/WORK(i), X(1,i), 1 ) ! BLAS CALL +! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC + ELSE IF ( WORK(i) < ZERO ) THEN + CALL DLASCL( 'G', 0, 0, -WORK(i), & + ONE/DBLE(M), M, 1, X(1,i), M, INFO2 ) ! LAPACK CALL + ELSE IF ( X(IDAMAX(M, X(1,i),1),i ) & + /= ZERO ) THEN +! Y(:,i) is zero vector. If X(:,i) is not +! zero, then a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + END IF + END DO + END IF +! +! <2> SVD of the data snapshot matrix X. +! ===================================== +! The left singular vectors are stored in the array X. +! The right singular vectors are in the array W. +! The array W will later on contain the eigenvectors +! of a Rayleigh quotient. + NUMRNK = N + SELECT CASE ( WHTSVD ) + CASE (1) + CALL DGESVD( 'O', 'S', M, N, X, LDX, WORK, B, & + LDB, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL + T_OR_N = 'T' + CASE (2) + CALL DGESDD( 'O', M, N, X, LDX, WORK, B, LDB, W, & + LDW, WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL + T_OR_N = 'T' + CASE (3) + CALL DGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, WORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, LIWORK, WORK(N+MAX(2,M)+1),& + LWORK-N-MAX(2,M), WORK(N+1), MAX(2,M), INFO1) ! LAPACK CALL + CALL DLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'T' + CASE (4) + CALL DGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & + N, X, LDX, WORK, Z, LDZ, W, LDW, & + WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL + CALL DLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'N' + XSCL1 = WORK(N+1) + XSCL2 = WORK(N+2) + IF ( XSCL1 /= XSCL2 ) THEN + ! This is an exceptional situation. If the + ! data matrices are not scaled and the + ! largest singular value of X overflows. + ! In that case DGEJSV can return the SVD + ! in scaled form. The scaling factor can be used + ! to rescale the data (X and Y). + CALL DLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) + END IF + END SELECT +! + IF ( INFO1 > 0 ) THEN + ! The SVD selected subroutine did not converge. + ! Return with an error code. + INFO = 2 + RETURN + END IF +! + IF ( WORK(1) == ZERO ) THEN + ! The largest computed singular value of (scaled) + ! X is zero. Return error code -8 + ! (the 8th input variable had an illegal value). + K = 0 + INFO = -8 + CALL XERBLA('DGEDMD',-INFO) + RETURN + END IF +! + !<3> Determine the numerical rank of the data + ! snapshots matrix X. This depends on the + ! parameters NRNK and TOL. + + SELECT CASE ( NRNK ) + CASE ( -1 ) + K = 1 + DO i = 2, NUMRNK + IF ( ( WORK(i) <= WORK(1)*TOL ) .OR. & + ( WORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE ( -2 ) + K = 1 + DO i = 1, NUMRNK-1 + IF ( ( WORK(i+1) <= WORK(i)*TOL ) .OR. & + ( WORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE DEFAULT + K = 1 + DO i = 2, NRNK + IF ( WORK(i) <= SMALL ) EXIT + K = K + 1 + END DO + END SELECT + ! Now, U = X(1:M,1:K) is the SVD/POD basis for the + ! snapshot data in the input matrix X. + + !<4> Compute the Rayleigh quotient S = U^T * A * U. + ! Depending on the requested outputs, the computation + ! is organized to compute additional auxiliary + ! matrices (for the residuals and refinements). + ! + ! In all formulas below, we need V_k*Sigma_k^(-1) + ! where either V_k is in W(1:N,1:K), or V_k^T is in + ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). + IF ( LSAME(T_OR_N, 'N') ) THEN + DO i = 1, K + CALL DSCAL( N, ONE/WORK(i), W(1,i), 1 ) ! BLAS CALL + ! W(1:N,i) = (ONE/WORK(i)) * W(1:N,i) ! INTRINSIC + END DO + ELSE + ! This non-unit stride access is due to the fact + ! that DGESVD, DGESVDQ and DGESDD return the + ! transposed matrix of the right singular vectors. + !DO i = 1, K + ! CALL DSCAL( N, ONE/WORK(i), W(i,1), LDW ) ! BLAS CALL + ! ! W(i,1:N) = (ONE/WORK(i)) * W(i,1:N) ! INTRINSIC + !END DO + DO i = 1, K + WORK(N+i) = ONE/WORK(i) + END DO + DO j = 1, N + DO i = 1, K + W(i,j) = (WORK(N+i))*W(i,j) + END DO + END DO + END IF +! + IF ( WNTREF ) THEN + ! + ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) + ! for computing the refined Ritz vectors + ! (optionally, outside DGEDMD). + CALL DGEMM( 'N', T_OR_N, M, K, N, ONE, Y, LDY, W, & + LDW, ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' + ! + ! At this point Z contains + ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and + ! this is needed for computing the residuals. + ! This matrix is returned in the array B and + ! it can be used to compute refined Ritz vectors. + CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL + ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC + + CALL DGEMM( 'T', 'N', K, K, M, ONE, X, LDX, Z, & + LDZ, ZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC + ! At this point S = U^T * A * U is the Rayleigh quotient. + ELSE + ! A * U(:,1:K) is not explicitly needed and the + ! computation is organized differently. The Rayleigh + ! quotient is computed more efficiently. + CALL DGEMM( 'T', 'N', K, N, M, ONE, X, LDX, Y, LDY, & + ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC + ! In the two DGEMM calls here, can use K for LDZ. + CALL DGEMM( 'N', T_OR_N, K, K, N, ONE, Z, LDZ, W, & + LDW, ZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' + ! At this point S = U^T * A * U is the Rayleigh quotient. + ! If the residuals are requested, save scaled V_k into Z. + ! Recall that V_k or V_k^T is stored in W. + IF ( WNTRES .OR. WNTEX ) THEN + IF ( LSAME(T_OR_N, 'N') ) THEN + CALL DLACPY( 'A', N, K, W, LDW, Z, LDZ ) + ELSE + CALL DLACPY( 'A', K, N, W, LDW, Z, LDZ ) + END IF + END IF + END IF +! + !<5> Compute the Ritz values and (if requested) the + ! right eigenvectors of the Rayleigh quotient. + ! + CALL DGEEV( 'N', JOBZL, K, S, LDS, REIG, IMEIG, W, & + LDW, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL + ! + ! W(1:K,1:K) contains the eigenvectors of the Rayleigh + ! quotient. Even in the case of complex spectrum, all + ! computation is done in real arithmetic. REIG and + ! IMEIG are the real and the imaginary parts of the + ! eigenvalues, so that the spectrum is given as + ! REIG(:) + sqrt(-1)*IMEIG(:). Complex conjugate pairs + ! are listed at consecutive positions. For such a + ! complex conjugate pair of the eigenvalues, the + ! corresponding eigenvectors are also a complex + ! conjugate pair with the real and imaginary parts + ! stored column-wise in W at the corresponding + ! consecutive column indices. See the description of Z. + ! Also, see the description of DGEEV. + IF ( INFO1 > 0 ) THEN + ! DGEEV failed to compute the eigenvalues and + ! eigenvectors of the Rayleigh quotient. + INFO = 3 + RETURN + END IF +! + ! <6> Compute the eigenvectors (if requested) and, + ! the residuals (if requested). + ! + IF ( WNTVEC .OR. WNTEX ) THEN + IF ( WNTRES ) THEN + IF ( WNTREF ) THEN + ! Here, if the refinement is requested, we have + ! A*U(:,1:K) already computed and stored in Z. + ! For the residuals, need Y = A * U(:,1;K) * W. + CALL DGEMM( 'N', 'N', M, K, K, ONE, Z, LDZ, W, & + LDW, ZERO, Y, LDY ) ! BLAS CALL + ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC + ! This frees Z; Y contains A * U(:,1:K) * W. + ELSE + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL DGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & + W, LDW, ZERO, S, LDS) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + LDS, ZERO, Z, LDZ) + ! Save a copy of Z into Y and free Z for holding + ! the Ritz vectors. + CALL DLACPY( 'A', M, K, Z, LDZ, Y, LDY ) + IF ( WNTEX ) CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF + ELSE IF ( WNTEX ) THEN + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL DGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & + W, LDW, ZERO, S, LDS ) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + LDS, ZERO, B, LDB ) + ! The above call replaces the following two calls + ! that were used in the developing-testing phase. + ! CALL DGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + ! LDS, ZERO, Z, LDZ) + ! Save a copy of Z into B and free Z for holding + ! the Ritz vectors. + ! CALL DLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF +! + ! Compute the real form of the Ritz vectors + IF ( WNTVEC ) CALL DGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & + ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC +! + IF ( WNTRES ) THEN + i = 1 + DO WHILE ( i <= K ) + IF ( IMEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL DAXPY( M, -REIG(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL + ! Y(1:M,i) = Y(1:M,i) - REIG(i) * Z(1:M,i) ! INTRINSIC + RES(i) = DNRM2( M, Y(1,i), 1) ! BLAS CALL + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IMEIG(i) + AB(1,2) = IMEIG(i) + AB(2,2) = REIG(i) + CALL DGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + LDZ, AB, 2, ONE, Y(1,i), LDY ) ! BLAS CALL + ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC + RES(i) = DLANGE( 'F', M, 2, Y(1,i), LDY, & + WORK(N+1) ) ! LAPACK CALL + RES(i+1) = RES(i) + i = i + 2 + END IF + END DO + END IF + END IF +! + IF ( WHTSVD == 4 ) THEN + WORK(N+1) = XSCL1 + WORK(N+2) = XSCL2 + END IF +! +! Successful exit. + IF ( .NOT. BADXY ) THEN + INFO = 0 + ELSE + ! A warning on possible data inconsistency. + ! This should be a rare event. + INFO = 4 + END IF +!............................................................ + RETURN +! ...... + END SUBROUTINE DGEDMD diff --git a/lapack-netlib/SRC/dgesvdx.f b/lapack-netlib/SRC/dgesvdx.f index db444b78de..f68b209fba 100644 --- a/lapack-netlib/SRC/dgesvdx.f +++ b/lapack-netlib/SRC/dgesvdx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DGESVDX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -254,12 +252,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleGEsing +*> \ingroup gesvdx * * ===================================================================== SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -294,7 +293,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DBDSVDX, DGEBRD, DGELQF, DGEQRF, DLACPY, + EXTERNAL DBDSVDX, DGEBRD, DGELQF, DGEQRF, + $ DLACPY, $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, $ DCOPY, XERBLA * .. @@ -384,7 +384,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MAXWRK = 1 IF( MINMN.GT.0 ) THEN IF( M.GE.N ) THEN - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( M.GE.MNTHR ) THEN * * Path 1 (M much larger than N) @@ -419,7 +420,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = MAX(N*(N*2+19),4*N+M) END IF ELSE - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M) @@ -541,8 +543,10 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUP = ITAUQ + N ITEMP = ITAUP + N CALL DLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), N ) - CALL DGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), + $ N ) + CALL DGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), + $ WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * @@ -551,7 +555,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -563,7 +568,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), + $ LDU ) * * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -620,7 +626,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -632,7 +639,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), + $ LDU ) * * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -689,8 +697,10 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUP = ITAUQ + M ITEMP = ITAUP + M CALL DLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M ) - CALL DGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), + $ M ) + CALL DGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), + $ WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * @@ -699,7 +709,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -728,7 +739,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), + $ LDVT) * * Call DORMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) @@ -768,7 +780,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -797,7 +810,8 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), + $ LDVT) * * Call DORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) @@ -811,13 +825,14 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Undo scaling if necessary * - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, + IF( ISCL.EQ.1 .AND. NS.GT.0 ) THEN + IF( ANRM.GT.BIGNUM ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, NS, 1, $ S, MINMN, INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, + ELSE IF( ANRM.LT.SMLNUM ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, NS, 1, $ S, MINMN, INFO ) + ENDIF END IF * * Return optimal workspace in WORK(1) diff --git a/lapack-netlib/SRC/dgesvj.f b/lapack-netlib/SRC/dgesvj.f index 198bfb0a50..ef17833baa 100644 --- a/lapack-netlib/SRC/dgesvj.f +++ b/lapack-netlib/SRC/dgesvj.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DGESVJ + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -103,7 +101,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. +*> The number of rows of the input matrix A. 1/DLAMCH('E') >= M >= 0. *> \endverbatim *> *> \param[in] N @@ -243,7 +241,7 @@ *> LWORK >= 1, if MIN(M,N) = 0, and LWORK >= MAX(6,M+N), otherwise. *> *> If on entry LWORK = -1, then a workspace query is assumed and -*> no computation is done; WORK(1) is set to the minial (and optimal) +*> no computation is done; WORK(1) is set to the minimal (and optimal) *> length of WORK. *> \endverbatim *> @@ -339,6 +337,7 @@ * ===================================================================== SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -366,7 +365,7 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, - $ THSIGN, TOL + $ THSIGN, TOL, TBIG INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, @@ -423,9 +422,13 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 - ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN + ELSE IF( .NOT.( LSVEC .OR. + $ UCTOL .OR. + $ LSAME( JOBU, 'N' ) ) ) THEN INFO = -2 - ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + ELSE IF( .NOT.( RSVEC .OR. + $ APPLV .OR. + $ LSAME( JOBV, 'N' ) ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 @@ -438,8 +441,6 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN INFO = -11 - ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN - INFO = -12 ELSE IF( LWORK.LT.LWMIN .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 ELSE @@ -468,7 +469,12 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( UCTOL ) THEN * ... user controlled - CTOL = WORK( 1 ) + IF( WORK( 1 ).LE.ONE ) THEN + INFO = -12 + RETURN + ELSE + CTOL = WORK( 1 ) + ENDIF ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN @@ -535,7 +541,9 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = DSQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT. TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -560,7 +568,9 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = DSQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -585,7 +595,9 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = DSQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -781,11 +793,13 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( UPPER ) THEN * * - CALL DGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV, + CALL DGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, + $ LDV, $ EPSLN, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N, $ IERR ) * - CALL DGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ), + CALL DGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, + $ WORK( N4+1 ), $ SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV, $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, $ IERR ) @@ -888,7 +902,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( DDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -903,7 +918,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( DDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -980,7 +996,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS - CALL DROTM( M, A( 1, p ), 1, + CALL DROTM( M, A( 1, p ), + $ 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, @@ -996,7 +1013,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS IF( RSVEC ) THEN - CALL DAXPY( MVL, -T*AQOAP, + CALL DAXPY( MVL, + $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, @@ -1010,13 +1028,15 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) - CALL DAXPY( M, -CS*SN*AQOAP, + CALL DAXPY( M, + $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS IF( RSVEC ) THEN - CALL DAXPY( MVL, T*APOAQ, + CALL DAXPY( MVL, + $ T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, @@ -1030,7 +1050,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) - CALL DAXPY( M, CS*SN*APOAQ, + CALL DAXPY( M, + $ CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS @@ -1073,15 +1094,19 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. have to use modified Gram-Schmidt like transformation CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, AAPP, ONE, M, + CALL DLASCL( 'G', 0, 0, AAPP, ONE, + $ M, $ 1, WORK( N+1 ), LDA, $ IERR ) - CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, + CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, $ 1, A( 1, q ), LDA, IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) - CALL DAXPY( M, TEMP1, WORK( N+1 ), 1, + CALL DAXPY( M, TEMP1, WORK( N+1 ), + $ 1, $ A( 1, q ), 1 ) - CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M, + CALL DLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, $ 1, A( 1, q ), LDA, IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) @@ -1096,7 +1121,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + SVA( q ) = DNRM2( M, A( 1, q ), + $ 1 )* $ WORK( q ) ELSE T = ZERO @@ -1195,7 +1221,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( DDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -1214,7 +1241,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( DDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -1286,7 +1314,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS - CALL DROTM( M, A( 1, p ), 1, + CALL DROTM( M, A( 1, p ), + $ 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, @@ -1300,7 +1329,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ A( 1, p ), 1, $ A( 1, q ), 1 ) IF( RSVEC ) THEN - CALL DAXPY( MVL, -T*AQOAP, + CALL DAXPY( MVL, + $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, @@ -1316,11 +1346,13 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) - CALL DAXPY( M, -CS*SN*AQOAP, + CALL DAXPY( M, + $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) IF( RSVEC ) THEN - CALL DAXPY( MVL, T*APOAQ, + CALL DAXPY( MVL, + $ T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, @@ -1336,7 +1368,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) - CALL DAXPY( M, CS*SN*APOAQ, + CALL DAXPY( M, + $ CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS @@ -1379,16 +1412,20 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAPP.GT.AAQQ ) THEN CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, AAPP, ONE, + CALL DLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) - CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + CALL DLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) - CALL DAXPY( M, TEMP1, WORK( N+1 ), + CALL DAXPY( M, TEMP1, + $ WORK( N+1 ), $ 1, A( 1, q ), 1 ) - CALL DLASCL( 'G', 0, 0, ONE, AAQQ, + CALL DLASCL( 'G', 0, 0, ONE, + $ AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, @@ -1397,16 +1434,20 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE CALL DCOPY( M, A( 1, q ), 1, $ WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, AAQQ, ONE, + CALL DLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) - CALL DLASCL( 'G', 0, 0, AAPP, ONE, + CALL DLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( q ) / WORK( p ) - CALL DAXPY( M, TEMP1, WORK( N+1 ), + CALL DAXPY( M, TEMP1, + $ WORK( N+1 ), $ 1, A( 1, p ), 1 ) - CALL DLASCL( 'G', 0, 0, ONE, AAPP, + CALL DLASCL( 'G', 0, 0, ONE, + $ AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*DSQRT( MAX( ZERO, @@ -1422,7 +1463,8 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = DNRM2( M, A( 1, q ), 1 )* + SVA( q ) = DNRM2( M, A( 1, q ), + $ 1 )* $ WORK( q ) ELSE T = ZERO @@ -1568,7 +1610,9 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( LSVEC .OR. UCTOL ) THEN DO 1998 p = 1, N2 - CALL DSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 ) + TEMP1 = ONE + IF( SVA(p).GT.ZERO ) TEMP1 = ONE/SVA(p) + CALL DSCAL( M, WORK( p )*TEMP1, A( 1, p ), 1 ) 1998 CONTINUE END IF * @@ -1588,9 +1632,14 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL) ) ) - $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. - $ ( SFMIN / SKL) ) ) ) THEN + NOSCALE = .FALSE. + IF ( SKL.GT.ONE ) THEN + IF( SVA( 1 ).LT.( BIG / SKL ) ) NOSCALE = .TRUE. + ELSE IF( SKL.LT.ONE ) THEN + IF ( SVA( MAX( N2, 1 ) ) .GT. + $ ( SFMIN / SKL ) ) NOSCALE = .TRUE. + ENDIF + IF( NOSCALE ) THEN DO 2400 p = 1, N SVA( P ) = SKL*SVA( P ) 2400 CONTINUE diff --git a/lapack-netlib/SRC/sgedmd.f90 b/lapack-netlib/SRC/sgedmd.f90 index 4860e88983..8bccec126a 100644 --- a/lapack-netlib/SRC/sgedmd.f90 +++ b/lapack-netlib/SRC/sgedmd.f90 @@ -1,1206 +1,1209 @@ -!> \brief \b SGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. -! -! =========== DOCUMENTATION =========== -! -! Definition: -! =========== -! -! SUBROUTINE SGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & -! M, N, X, LDX, Y, LDY, NRNK, TOL, & -! K, REIG, IMEIG, Z, LDZ, RES, & -! B, LDB, W, LDW, S, LDS, & -! WORK, LWORK, IWORK, LIWORK, INFO ) -!..... -! USE iso_fortran_env -! IMPLICIT NONE -! INTEGER, PARAMETER :: WP = real32 -!..... -! Scalar arguments -! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF -! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & -! NRNK, LDZ, LDB, LDW, LDS, & -! LWORK, LIWORK -! INTEGER, INTENT(OUT) :: K, INFO -! REAL(KIND=WP), INTENT(IN) :: TOL -! Array arguments -! REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) -! REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & -! W(LDW,*), S(LDS,*) -! REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & -! RES(*) -! REAL(KIND=WP), INTENT(OUT) :: WORK(*) -! INTEGER, INTENT(OUT) :: IWORK(*) -! -!............................................................ -!> \par Purpose: -! ============= -!> \verbatim -!> SGEDMD computes the Dynamic Mode Decomposition (DMD) for -!> a pair of data snapshot matrices. For the input matrices -!> X and Y such that Y = A*X with an unaccessible matrix -!> A, SGEDMD computes a certain number of Ritz pairs of A using -!> the standard Rayleigh-Ritz extraction from a subspace of -!> range(X) that is determined using the leading left singular -!> vectors of X. Optionally, SGEDMD returns the residuals -!> of the computed Ritz pairs, the information needed for -!> a refinement of the Ritz vectors, or the eigenvectors of -!> the Exact DMD. -!> For further details see the references listed -!> below. For more details of the implementation see [3]. -!> \endverbatim -!............................................................ -!> \par References: -! ================ -!> \verbatim -!> [1] P. Schmid: Dynamic mode decomposition of numerical -!> and experimental data, -!> Journal of Fluid Mechanics 656, 5-28, 2010. -!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal -!> decompositions: analysis and enhancements, -!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. -!> [3] Z. Drmac: A LAPACK implementation of the Dynamic -!> Mode Decomposition I. Technical report. AIMDyn Inc. -!> and LAPACK Working Note 298. -!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. -!> Brunton, N. Kutz: On Dynamic Mode Decomposition: -!> Theory and Applications, Journal of Computational -!> Dynamics 1(2), 391 -421, 2014. -!> \endverbatim -!...................................................................... -!> \par Developed and supported by: -! ================================ -!> \verbatim -!> Developed and coded by Zlatko Drmac, Faculty of Science, -!> University of Zagreb; drmac@math.hr -!> In cooperation with -!> AIMdyn Inc., Santa Barbara, CA. -!> and supported by -!> - DARPA SBIR project "Koopman Operator-Based Forecasting -!> for Nonstationary Processes from Near-Term, Limited -!> Observational Data" Contract No: W31P4Q-21-C-0007 -!> - DARPA PAI project "Physics-Informed Machine Learning -!> Methodologies" Contract No: HR0011-18-9-0033 -!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic -!> Framework for Space-Time Analysis of Process Dynamics" -!> Contract No: HR0011-16-C-0116 -!> Any opinions, findings and conclusions or recommendations -!> expressed in this material are those of the author and -!> do not necessarily reflect the views of the DARPA SBIR -!> Program Office -!> \endverbatim -!...................................................................... -!> \par Distribution Statement A: -! ============================== -!> \verbatim -!> Distribution Statement A: -!> Approved for Public Release, Distribution Unlimited. -!> Cleared by DARPA on September 29, 2022 -!> \endverbatim -!============================================================ -! Arguments -! ========= -! -!> \param[in] JOBS -!> \verbatim -!> JOBS (input) CHARACTER*1 -!> Determines whether the initial data snapshots are scaled -!> by a diagonal matrix. -!> 'S' :: The data snapshots matrices X and Y are multiplied -!> with a diagonal matrix D so that X*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'C' :: The snapshots are scaled as with the 'S' option. -!> If it is found that an i-th column of X is zero -!> vector and the corresponding i-th column of Y is -!> non-zero, then the i-th column of Y is set to -!> zero and a warning flag is raised. -!> 'Y' :: The data snapshots matrices X and Y are multiplied -!> by a diagonal matrix D so that Y*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'N' :: No data scaling. -!> \endverbatim -!..... -!> \param[in] JOBZ -!> \verbatim -!> JOBZ (input) CHARACTER*1 -!> Determines whether the eigenvectors (Koopman modes) will -!> be computed. -!> 'V' :: The eigenvectors (Koopman modes) will be computed -!> and returned in the matrix Z. -!> See the description of Z. -!> 'F' :: The eigenvectors (Koopman modes) will be returned -!> in factored form as the product X(:,1:K)*W, where X -!> contains a POD basis (leading left singular vectors -!> of the data matrix X) and W contains the eigenvectors -!> of the corresponding Rayleigh quotient. -!> See the descriptions of K, X, W, Z. -!> 'N' :: The eigenvectors are not computed. -!> \endverbatim -!..... -!> \param[in] JOBR -!> \verbatim -!> JOBR (input) CHARACTER*1 -!> Determines whether to compute the residuals. -!> 'R' :: The residuals for the computed eigenpairs will be -!> computed and stored in the array RES. -!> See the description of RES. -!> For this option to be legal, JOBZ must be 'V'. -!> 'N' :: The residuals are not computed. -!> \endverbatim -!..... -!> \param[in] JOBF -!> \verbatim -!> JOBF (input) CHARACTER*1 -!> Specifies whether to store information needed for post- -!> processing (e.g. computing refined Ritz vectors) -!> 'R' :: The matrix needed for the refinement of the Ritz -!> vectors is computed and stored in the array B. -!> See the description of B. -!> 'E' :: The unscaled eigenvectors of the Exact DMD are -!> computed and returned in the array B. See the -!> description of B. -!> 'N' :: No eigenvector refinement data is computed. -!> \endverbatim -!..... -!> \param[in] WHTSVD -!> \verbatim -!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } -!> Allows for a selection of the SVD algorithm from the -!> LAPACK library. -!> 1 :: SGESVD (the QR SVD algorithm) -!> 2 :: SGESDD (the Divide and Conquer algorithm; if enough -!> workspace available, this is the fastest option) -!> 3 :: SGESVDQ (the preconditioned QR SVD ; this and 4 -!> are the most accurate options) -!> 4 :: SGEJSV (the preconditioned Jacobi SVD; this and 3 -!> are the most accurate options) -!> For the four methods above, a significant difference in -!> the accuracy of small singular values is possible if -!> the snapshots vary in norm so that X is severely -!> ill-conditioned. If small (smaller than EPS*||X||) -!> singular values are of interest and JOBS=='N', then -!> the options (3, 4) give the most accurate results, where -!> the option 4 is slightly better and with stronger -!> theoretical background. -!> If JOBS=='S', i.e. the columns of X will be normalized, -!> then all methods give nearly equally accurate results. -!> \endverbatim -!..... -!> \param[in] M -!> \verbatim -!> M (input) INTEGER, M>= 0 -!> The state space dimension (the row dimension of X, Y). -!> \endverbatim -!..... -!> \param[in] N -!> \verbatim -!> N (input) INTEGER, 0 <= N <= M -!> The number of data snapshot pairs -!> (the number of columns of X and Y). -!> \endverbatim -!..... -!> \param[in,out] X -!> \verbatim -!> X (input/output) REAL(KIND=WP) M-by-N array -!> > On entry, X contains the data snapshot matrix X. It is -!> assumed that the column norms of X are in the range of -!> the normalized floating point numbers. -!> < On exit, the leading K columns of X contain a POD basis, -!> i.e. the leading K left singular vectors of the input -!> data matrix X, U(:,1:K). All N columns of X contain all -!> left singular vectors of the input matrix X. -!> See the descriptions of K, Z and W. -!> \endverbatim -!..... -!> \param[in] LDX -!> \verbatim -!> LDX (input) INTEGER, LDX >= M -!> The leading dimension of the array X. -!> \endverbatim -!..... -!> \param[in,out] Y -!> \verbatim -!> Y (input/workspace/output) REAL(KIND=WP) M-by-N array -!> > On entry, Y contains the data snapshot matrix Y -!> < On exit, -!> If JOBR == 'R', the leading K columns of Y contain -!> the residual vectors for the computed Ritz pairs. -!> See the description of RES. -!> If JOBR == 'N', Y contains the original input data, -!> scaled according to the value of JOBS. -!> \endverbatim -!..... -!> \param[in] LDY -!> \verbatim -!> LDY (input) INTEGER , LDY >= M -!> The leading dimension of the array Y. -!> \endverbatim -!..... -!> \param[in] NRNK -!> \verbatim -!> NRNK (input) INTEGER -!> Determines the mode how to compute the numerical rank, -!> i.e. how to truncate small singular values of the input -!> matrix X. On input, if -!> NRNK = -1 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(1) -!> This option is recommended. -!> NRNK = -2 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(i-1) -!> This option is included for R&D purposes. -!> It requires highly accurate SVD, which -!> may not be feasible. -!> The numerical rank can be enforced by using positive -!> value of NRNK as follows: -!> 0 < NRNK <= N :: at most NRNK largest singular values -!> will be used. If the number of the computed nonzero -!> singular values is less than NRNK, then only those -!> nonzero values will be used and the actually used -!> dimension is less than NRNK. The actual number of -!> the nonzero singular values is returned in the variable -!> K. See the descriptions of TOL and K. -!> \endverbatim -!..... -!> \param[in] TOL -!> \verbatim -!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 -!> The tolerance for truncating small singular values. -!> See the description of NRNK. -!> \endverbatim -!..... -!> \param[out] K -!> \verbatim -!> K (output) INTEGER, 0 <= K <= N -!> The dimension of the POD basis for the data snapshot -!> matrix X and the number of the computed Ritz pairs. -!> The value of K is determined according to the rule set -!> by the parameters NRNK and TOL. -!> See the descriptions of NRNK and TOL. -!> \endverbatim -!..... -!> \param[out] REIG -!> \verbatim -!> REIG (output) REAL(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of REIG contain -!> the real parts of the computed eigenvalues -!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). -!> See the descriptions of K, IMEIG, and Z. -!> \endverbatim -!..... -!> \param[out] IMEIG -!> \verbatim -!> IMEIG (output) REAL(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of IMEIG contain -!> the imaginary parts of the computed eigenvalues -!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). -!> The eigenvalues are determined as follows: -!> If IMEIG(i) == 0, then the corresponding eigenvalue is -!> real, LAMBDA(i) = REIG(i). -!> If IMEIG(i)>0, then the corresponding complex -!> conjugate pair of eigenvalues reads -!> LAMBDA(i) = REIG(i) + sqrt(-1)*IMAG(i) -!> LAMBDA(i+1) = REIG(i) - sqrt(-1)*IMAG(i) -!> That is, complex conjugate pairs have consecutive -!> indices (i,i+1), with the positive imaginary part -!> listed first. -!> See the descriptions of K, REIG, and Z. -!> \endverbatim -!..... -!> \param[out] Z -!> \verbatim -!> Z (workspace/output) REAL(KIND=WP) M-by-N array -!> If JOBZ =='V' then -!> Z contains real Ritz vectors as follows: -!> If IMEIG(i)=0, then Z(:,i) is an eigenvector of -!> the i-th Ritz value; ||Z(:,i)||_2=1. -!> If IMEIG(i) > 0 (and IMEIG(i+1) < 0) then -!> [Z(:,i) Z(:,i+1)] span an invariant subspace and -!> the Ritz values extracted from this subspace are -!> REIG(i) + sqrt(-1)*IMEIG(i) and -!> REIG(i) - sqrt(-1)*IMEIG(i). -!> The corresponding eigenvectors are -!> Z(:,i) + sqrt(-1)*Z(:,i+1) and -!> Z(:,i) - sqrt(-1)*Z(:,i+1), respectively. -!> || Z(:,i:i+1)||_F = 1. -!> If JOBZ == 'F', then the above descriptions hold for -!> the columns of X(:,1:K)*W(1:K,1:K), where the columns -!> of W(1:k,1:K) are the computed eigenvectors of the -!> K-by-K Rayleigh quotient. The columns of W(1:K,1:K) -!> are similarly structured: If IMEIG(i) == 0 then -!> X(:,1:K)*W(:,i) is an eigenvector, and if IMEIG(i)>0 -!> then X(:,1:K)*W(:,i)+sqrt(-1)*X(:,1:K)*W(:,i+1) and -!> X(:,1:K)*W(:,i)-sqrt(-1)*X(:,1:K)*W(:,i+1) -!> are the eigenvectors of LAMBDA(i), LAMBDA(i+1). -!> See the descriptions of REIG, IMEIG, X and W. -!> \endverbatim -!..... -!> \param[in] LDZ -!> \verbatim -!> LDZ (input) INTEGER , LDZ >= M -!> The leading dimension of the array Z. -!> \endverbatim -!..... -!> \param[out] RES -!> \verbatim -!> RES (output) REAL(KIND=WP) N-by-1 array -!> RES(1:K) contains the residuals for the K computed -!> Ritz pairs. -!> If LAMBDA(i) is real, then -!> RES(i) = || A * Z(:,i) - LAMBDA(i)*Z(:,i))||_2. -!> If [LAMBDA(i), LAMBDA(i+1)] is a complex conjugate pair -!> then -!> RES(i)=RES(i+1) = || A * Z(:,i:i+1) - Z(:,i:i+1) *B||_F -!> where B = [ real(LAMBDA(i)) imag(LAMBDA(i)) ] -!> [-imag(LAMBDA(i)) real(LAMBDA(i)) ]. -!> It holds that -!> RES(i) = || A*ZC(:,i) - LAMBDA(i) *ZC(:,i) ||_2 -!> RES(i+1) = || A*ZC(:,i+1) - LAMBDA(i+1)*ZC(:,i+1) ||_2 -!> where ZC(:,i) = Z(:,i) + sqrt(-1)*Z(:,i+1) -!> ZC(:,i+1) = Z(:,i) - sqrt(-1)*Z(:,i+1) -!> See the description of REIG, IMEIG and Z. -!> \endverbatim -!..... -!> \param[out] B -!> \verbatim -!> B (output) REAL(KIND=WP) M-by-N array. -!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can -!> be used for computing the refined vectors; see further -!> details in the provided references. -!> If JOBF == 'E', B(1:M,1;K) contains -!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the -!> Exact DMD, up to scaling by the inverse eigenvalues. -!> If JOBF =='N', then B is not referenced. -!> See the descriptions of X, W, K. -!> \endverbatim -!..... -!> \param[in] LDB -!> \verbatim -!> LDB (input) INTEGER, LDB >= M -!> The leading dimension of the array B. -!> \endverbatim -!..... -!> \param[out] W -!> \verbatim -!> W (workspace/output) REAL(KIND=WP) N-by-N array -!> On exit, W(1:K,1:K) contains the K computed -!> eigenvectors of the matrix Rayleigh quotient (real and -!> imaginary parts for each complex conjugate pair of the -!> eigenvalues). The Ritz vectors (returned in Z) are the -!> product of X (containing a POD basis for the input -!> matrix X) and W. See the descriptions of K, S, X and Z. -!> W is also used as a workspace to temporarily store the -!> left singular vectors of X. -!> \endverbatim -!..... -!> \param[in] LDW -!> \verbatim -!> LDW (input) INTEGER, LDW >= N -!> The leading dimension of the array W. -!> \endverbatim -!..... -!> \param[out] S -!> \verbatim -!> S (workspace/output) REAL(KIND=WP) N-by-N array -!> The array S(1:K,1:K) is used for the matrix Rayleigh -!> quotient. This content is overwritten during -!> the eigenvalue decomposition by SGEEV. -!> See the description of K. -!> \endverbatim -!..... -!> \param[in] LDS -!> \verbatim -!> LDS (input) INTEGER, LDS >= N -!> The leading dimension of the array S. -!> \endverbatim -!..... -!> \param[out] WORK -!> \verbatim -!> WORK (workspace/output) REAL(KIND=WP) LWORK-by-1 array -!> On exit, WORK(1:N) contains the singular values of -!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). -!> If WHTSVD==4, then WORK(N+1) and WORK(N+2) contain -!> scaling factor WORK(N+2)/WORK(N+1) used to scale X -!> and Y to avoid overflow in the SVD of X. -!> This may be of interest if the scaling option is off -!> and as many as possible smallest eigenvalues are -!> desired to the highest feasible accuracy. -!> If the call to SGEDMD is only workspace query, then -!> WORK(1) contains the minimal workspace length and -!> WORK(2) is the optimal workspace length. Hence, the -!> length of work is at least 2. -!> See the description of LWORK. -!> \endverbatim -!..... -!> \param[in] LWORK -!> \verbatim -!> LWORK (input) INTEGER -!> The minimal length of the workspace vector WORK. -!> LWORK is calculated as follows: -!> If WHTSVD == 1 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)). -!> If JOBZ == 'N' then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)). -!> Here LWORK_SVD = MAX(1,3*N+M,5*N) is the minimal -!> workspace length of SGESVD. -!> If WHTSVD == 2 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)) -!> Here LWORK_SVD = MAX(M, 5*N*N+4*N)+3*N*N is the -!> minimal workspace length of SGESDD. -!> If WHTSVD == 3 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) -!> Here LWORK_SVD = N+M+MAX(3*N+1, -!> MAX(1,3*N+M,5*N),MAX(1,N)) -!> is the minimal workspace length of SGESVDQ. -!> If WHTSVD == 4 :: -!> If JOBZ == 'V', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) -!> If JOBZ == 'N', then -!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) -!> Here LWORK_SVD = MAX(7,2*M+N,6*N+2*N*N) is the -!> minimal workspace length of SGEJSV. -!> The above expressions are not simplified in order to -!> make the usage of WORK more transparent, and for -!> easier checking. In any case, LWORK >= 2. -!> If on entry LWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for both WORK and -!> IWORK. See the descriptions of WORK and IWORK. -!> \endverbatim -!..... -!> \param[out] IWORK -!> \verbatim -!> IWORK (workspace/output) INTEGER LIWORK-by-1 array -!> Workspace that is required only if WHTSVD equals -!> 2 , 3 or 4. (See the description of WHTSVD). -!> If on entry LWORK =-1 or LIWORK=-1, then the -!> minimal length of IWORK is computed and returned in -!> IWORK(1). See the description of LIWORK. -!> \endverbatim -!..... -!> \param[in] LIWORK -!> \verbatim -!> LIWORK (input) INTEGER -!> The minimal length of the workspace vector IWORK. -!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 -!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) -!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) -!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) -!> If on entry LIWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for both WORK and -!> IWORK. See the descriptions of WORK and IWORK. -!> \endverbatim -!..... -!> \param[out] INFO -!> \verbatim -!> INFO (output) INTEGER -!> -i < 0 :: On entry, the i-th argument had an -!> illegal value -!> = 0 :: Successful return. -!> = 1 :: Void input. Quick exit (M=0 or N=0). -!> = 2 :: The SVD computation of X did not converge. -!> Suggestion: Check the input data and/or -!> repeat with different WHTSVD. -!> = 3 :: The computation of the eigenvalues did not -!> converge. -!> = 4 :: If data scaling was requested on input and -!> the procedure found inconsistency in the data -!> such that for some column index i, -!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set -!> to zero if JOBS=='C'. The computation proceeds -!> with original or modified data and warning -!> flag is set with INFO=4. -!> \endverbatim -! -! Authors: -! ======== -! -!> \author Zlatko Drmac -! -!> \ingroup gedmd -! -!............................................................. -!............................................................. - SUBROUTINE SGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & - M, N, X, LDX, Y, LDY, NRNK, TOL, & - K, REIG, IMEIG, Z, LDZ, RES, & - B, LDB, W, LDW, S, LDS, & - WORK, LWORK, IWORK, LIWORK, INFO ) -! -! -- LAPACK driver routine -- -! -! -- LAPACK is a software package provided by University of -- -! -- Tennessee, University of California Berkeley, University of -- -! -- Colorado Denver and NAG Ltd.. -- -! -!..... - USE iso_fortran_env - IMPLICIT NONE - INTEGER, PARAMETER :: WP = real32 -! -! Scalar arguments -! ~~~~~~~~~~~~~~~~ - CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF - INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & - NRNK, LDZ, LDB, LDW, LDS, & - LWORK, LIWORK - INTEGER, INTENT(OUT) :: K, INFO - REAL(KIND=WP), INTENT(IN) :: TOL -! -! Array arguments -! ~~~~~~~~~~~~~~~ - REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) - REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & - W(LDW,*), S(LDS,*) - REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & - RES(*) - REAL(KIND=WP), INTENT(OUT) :: WORK(*) - INTEGER, INTENT(OUT) :: IWORK(*) -! -! Parameters -! ~~~~~~~~~~ - REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP - REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP -! -! Local scalars -! ~~~~~~~~~~~~~ - REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & - SSUM, XSCL1, XSCL2 - INTEGER :: i, j, IMINWR, INFO1, INFO2, & - LWRKEV, LWRSDD, LWRSVD, & - LWRSVQ, MLWORK, MWRKEV, MWRSDD, & - MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & - OLWORK - LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & - WNTEX, WNTREF, WNTRES, WNTVEC - CHARACTER :: JOBZL, T_OR_N - CHARACTER :: JSVOPT -! -! Local arrays -! ~~~~~~~~~~~~ - REAL(KIND=WP) :: AB(2,2), RDUMMY(2), RDUMMY2(2) -! -! External functions (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~ - REAL(KIND=WP) SLANGE, SLAMCH, SNRM2 - EXTERNAL SLANGE, SLAMCH, SNRM2, ISAMAX - INTEGER ISAMAX - LOGICAL SISNAN, LSAME - EXTERNAL SISNAN, LSAME -! -! External subroutines (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~~~~ - EXTERNAL SAXPY, SGEMM, SSCAL - EXTERNAL SGEEV, SGEJSV, SGESDD, SGESVD, SGESVDQ, & - SLACPY, SLASCL, SLASSQ, XERBLA -! -! Intrinsic functions -! ~~~~~~~~~~~~~~~~~~~ - INTRINSIC INT, FLOAT, MAX, SQRT -!............................................................ -! -! Test the input arguments -! - WNTRES = LSAME(JOBR,'R') - SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') - SCCOLY = LSAME(JOBS,'Y') - WNTVEC = LSAME(JOBZ,'V') - WNTREF = LSAME(JOBF,'R') - WNTEX = LSAME(JOBF,'E') - INFO = 0 - LQUERY = ( ( LWORK == -1 ) .OR. ( LIWORK == -1 ) ) -! - IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & - LSAME(JOBS,'N')) ) THEN - INFO = -1 - ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & - .OR. LSAME(JOBZ,'F')) ) THEN - INFO = -2 - ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & - ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN - INFO = -3 - ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & - LSAME(JOBF,'N') ) ) THEN - INFO = -4 - ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & - (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN - INFO = -5 - ELSE IF ( M < 0 ) THEN - INFO = -6 - ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN - INFO = -7 - ELSE IF ( LDX < M ) THEN - INFO = -9 - ELSE IF ( LDY < M ) THEN - INFO = -11 - ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & - ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN - INFO = -12 - ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN - INFO = -13 - ELSE IF ( LDZ < M ) THEN - INFO = -18 - ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN - INFO = -21 - ELSE IF ( LDW < N ) THEN - INFO = -23 - ELSE IF ( LDS < N ) THEN - INFO = -25 - END IF -! - IF ( INFO == 0 ) THEN - ! Compute the minimal and the optimal workspace - ! requirements. Simulate running the code and - ! determine minimal and optimal sizes of the - ! workspace at any moment of the run. - IF ( N == 0 ) THEN - ! Quick return. All output except K is void. - ! INFO=1 signals the void input. - ! In case of a workspace query, the default - ! minimal workspace lengths are returned. - IF ( LQUERY ) THEN - IWORK(1) = 1 - WORK(1) = 2 - WORK(2) = 2 - ELSE - K = 0 - END IF - INFO = 1 - RETURN - END IF - MLWORK = MAX(2,N) - OLWORK = MAX(2,N) - IMINWR = 1 - SELECT CASE ( WHTSVD ) - CASE (1) - ! The following is specified as the minimal - ! length of WORK in the definition of SGESVD: - ! MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - MLWORK = MAX(MLWORK,N + MWRSVD) - IF ( LQUERY ) THEN - CALL SGESVD( 'O', 'S', M, N, X, LDX, WORK, & - B, LDB, W, LDW, RDUMMY, -1, INFO1 ) - LWRSVD = MAX( MWRSVD, INT( RDUMMY(1) ) ) - OLWORK = MAX(OLWORK,N + LWRSVD) - END IF - CASE (2) - ! The following is specified as the minimal - ! length of WORK in the definition of SGESDD: - ! MWRSDD = 3*MIN(M,N)*MIN(M,N) + - ! MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) - ! IMINWR = 8*MIN(M,N) - MWRSDD = 3*MIN(M,N)*MIN(M,N) + & - MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) - MLWORK = MAX(MLWORK,N + MWRSDD) - IMINWR = 8*MIN(M,N) - IF ( LQUERY ) THEN - CALL SGESDD( 'O', M, N, X, LDX, WORK, B, & - LDB, W, LDW, RDUMMY, -1, IWORK, INFO1 ) - LWRSDD = MAX( MWRSDD, INT( RDUMMY(1) ) ) - OLWORK = MAX(OLWORK,N + LWRSDD) - END IF - CASE (3) - !LWQP3 = 3*N+1 - !LWORQ = MAX(N, 1) - !MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) - !MWRSVQ = N + MAX( LWQP3, MWRSVD, LWORQ )+ MAX(M,2) - !MLWORK = N + MWRSVQ - !IMINWR = M+N-1 - CALL SGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, WORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, -1, RDUMMY, & - -1, RDUMMY2, -1, INFO1 ) - IMINWR = IWORK(1) - MWRSVQ = INT(RDUMMY(2)) - MLWORK = MAX(MLWORK,N+MWRSVQ+INT(RDUMMY2(1))) - IF ( LQUERY ) THEN - LWRSVQ = INT(RDUMMY(1)) - OLWORK = MAX(OLWORK,N+LWRSVQ+INT(RDUMMY2(1))) - END IF - CASE (4) - JSVOPT = 'J' - !MWRSVJ = MAX( 7, 2*M+N, 6*N+2*N*N )! for JSVOPT='V' - MWRSVJ = MAX( 7, 2*M+N, 4*N+N*N, 2*N+N*N+6 ) - MLWORK = MAX(MLWORK,N+MWRSVJ) - IMINWR = MAX( 3, M+3*N ) - IF ( LQUERY ) THEN - OLWORK = MAX(OLWORK,N+MWRSVJ) - END IF - END SELECT - IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN - JOBZL = 'V' - ELSE - JOBZL = 'N' - END IF - ! Workspace calculation to the SGEEV call - IF ( LSAME(JOBZL,'V') ) THEN - MWRKEV = MAX( 1, 4*N ) - ELSE - MWRKEV = MAX( 1, 3*N ) - END IF - MLWORK = MAX(MLWORK,N+MWRKEV) - IF ( LQUERY ) THEN - CALL SGEEV( 'N', JOBZL, N, S, LDS, REIG, & - IMEIG, W, LDW, W, LDW, RDUMMY, -1, INFO1 ) - LWRKEV = MAX( MWRKEV, INT(RDUMMY(1)) ) - OLWORK = MAX( OLWORK, N+LWRKEV ) - END IF -! - IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -29 - IF ( LWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -27 - END IF -! - IF( INFO /= 0 ) THEN - CALL XERBLA( 'SGEDMD', -INFO ) - RETURN - ELSE IF ( LQUERY ) THEN -! Return minimal and optimal workspace sizes - IWORK(1) = IMINWR - WORK(1) = MLWORK - WORK(2) = OLWORK - RETURN - END IF -!............................................................ -! - OFL = SLAMCH('O') - SMALL = SLAMCH('S') - BADXY = .FALSE. -! -! <1> Optional scaling of the snapshots (columns of X, Y) -! ========================================================== - IF ( SCCOLX ) THEN - ! The columns of X will be normalized. - ! To prevent overflows, the column norms of X are - ! carefully computed using SLASSQ. - K = 0 - DO i = 1, N - !WORK(i) = DNRM2( M, X(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL SLASSQ( M, X(1,i), 1, SCALE, SSUM ) - IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN - K = 0 - INFO = -8 - CALL XERBLA('SGEDMD',-INFO) - END IF - IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of X(:,i) overflows. First, X(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. -! Next, the norm of X(:,i) is stored without -! overflow as WORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of X(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL SLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, X(1,i), M, INFO2 ) - WORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - WORK(i) = SCALE * ROOTSC - CALL SLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & - X(1,i), M, INFO2 ) ! LAPACK CALL -! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC - END IF - ELSE - WORK(i) = ZERO - K = K + 1 - END IF - END DO - IF ( K == N ) THEN - ! All columns of X are zero. Return error code -8. - ! (the 8th input variable had an illegal value) - K = 0 - INFO = -8 - CALL XERBLA('SGEDMD',-INFO) - RETURN - END IF - DO i = 1, N -! Now, apply the same scaling to the columns of Y. - IF ( WORK(i) > ZERO ) THEN - CALL SSCAL( M, ONE/WORK(i), Y(1,i), 1 ) ! BLAS CALL -! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC - ELSE IF ( WORK(i) < ZERO ) THEN - CALL SLASCL( 'G', 0, 0, -WORK(i), & - ONE/FLOAT(M), M, 1, Y(1,i), M, INFO2 ) ! LAPACK CALL - ELSE IF ( Y(ISAMAX(M, Y(1,i),1),i ) & - /= ZERO ) THEN -! X(:,i) is zero vector. For consistency, -! Y(:,i) should also be zero. If Y(:,i) is not -! zero, then the data might be inconsistent or -! corrupted. If JOBS == 'C', Y(:,i) is set to -! zero and a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - IF ( LSAME(JOBS,'C')) & - CALL SSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL - END IF - END DO - END IF - ! - IF ( SCCOLY ) THEN - ! The columns of Y will be normalized. - ! To prevent overflows, the column norms of Y are - ! carefully computed using SLASSQ. - DO i = 1, N - !WORK(i) = DNRM2( M, Y(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL SLASSQ( M, Y(1,i), 1, SCALE, SSUM ) - IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN - K = 0 - INFO = -10 - CALL XERBLA('SGEDMD',-INFO) - END IF - IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of Y(:,i) overflows. First, Y(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. -! Next, the norm of Y(:,i) is stored without -! overflow as WORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of Y(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL SLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, Y(1,i), M, INFO2 ) - WORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - WORK(i) = SCALE * ROOTSC - CALL SLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & - Y(1,i), M, INFO2 ) ! LAPACK CALL -! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC - END IF - ELSE - WORK(i) = ZERO - END IF - END DO - DO i = 1, N -! Now, apply the same scaling to the columns of X. - IF ( WORK(i) > ZERO ) THEN - CALL SSCAL( M, ONE/WORK(i), X(1,i), 1 ) ! BLAS CALL -! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC - ELSE IF ( WORK(i) < ZERO ) THEN - CALL SLASCL( 'G', 0, 0, -WORK(i), & - ONE/FLOAT(M), M, 1, X(1,i), M, INFO2 ) ! LAPACK CALL - ELSE IF ( X(ISAMAX(M, X(1,i),1),i ) & - /= ZERO ) THEN -! Y(:,i) is zero vector. If X(:,i) is not -! zero, then a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - END IF - END DO - END IF -! -! <2> SVD of the data snapshot matrix X. -! ===================================== -! The left singular vectors are stored in the array X. -! The right singular vectors are in the array W. -! The array W will later on contain the eigenvectors -! of a Rayleigh quotient. - NUMRNK = N - SELECT CASE ( WHTSVD ) - CASE (1) - CALL SGESVD( 'O', 'S', M, N, X, LDX, WORK, B, & - LDB, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL - T_OR_N = 'T' - CASE (2) - CALL SGESDD( 'O', M, N, X, LDX, WORK, B, LDB, W, & - LDW, WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL - T_OR_N = 'T' - CASE (3) - CALL SGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, WORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, LIWORK, WORK(N+MAX(2,M)+1),& - LWORK-N-MAX(2,M), WORK(N+1), MAX(2,M), INFO1) ! LAPACK CALL - CALL SLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'T' - CASE (4) - CALL SGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & - N, X, LDX, WORK, Z, LDZ, W, LDW, & - WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL - CALL SLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'N' - XSCL1 = WORK(N+1) - XSCL2 = WORK(N+2) - IF ( XSCL1 /= XSCL2 ) THEN - ! This is an exceptional situation. If the - ! data matrices are not scaled and the - ! largest singular value of X overflows. - ! In that case SGEJSV can return the SVD - ! in scaled form. The scaling factor can be used - ! to rescale the data (X and Y). - CALL SLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) - END IF - END SELECT -! - IF ( INFO1 > 0 ) THEN - ! The SVD selected subroutine did not converge. - ! Return with an error code. - INFO = 2 - RETURN - END IF -! - IF ( WORK(1) == ZERO ) THEN - ! The largest computed singular value of (scaled) - ! X is zero. Return error code -8 - ! (the 8th input variable had an illegal value). - K = 0 - INFO = -8 - CALL XERBLA('SGEDMD',-INFO) - RETURN - END IF -! - !<3> Determine the numerical rank of the data - ! snapshots matrix X. This depends on the - ! parameters NRNK and TOL. - - SELECT CASE ( NRNK ) - CASE ( -1 ) - K = 1 - DO i = 2, NUMRNK - IF ( ( WORK(i) <= WORK(1)*TOL ) .OR. & - ( WORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE ( -2 ) - K = 1 - DO i = 1, NUMRNK-1 - IF ( ( WORK(i+1) <= WORK(i)*TOL ) .OR. & - ( WORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE DEFAULT - K = 1 - DO i = 2, NRNK - IF ( WORK(i) <= SMALL ) EXIT - K = K + 1 - END DO - END SELECT - ! Now, U = X(1:M,1:K) is the SVD/POD basis for the - ! snapshot data in the input matrix X. - - !<4> Compute the Rayleigh quotient S = U^T * A * U. - ! Depending on the requested outputs, the computation - ! is organized to compute additional auxiliary - ! matrices (for the residuals and refinements). - ! - ! In all formulas below, we need V_k*Sigma_k^(-1) - ! where either V_k is in W(1:N,1:K), or V_k^T is in - ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). - IF ( LSAME(T_OR_N, 'N') ) THEN - DO i = 1, K - CALL SSCAL( N, ONE/WORK(i), W(1,i), 1 ) ! BLAS CALL - ! W(1:N,i) = (ONE/WORK(i)) * W(1:N,i) ! INTRINSIC - END DO - ELSE - ! This non-unit stride access is due to the fact - ! that SGESVD, SGESVDQ and SGESDD return the - ! transposed matrix of the right singular vectors. - !DO i = 1, K - ! CALL SSCAL( N, ONE/WORK(i), W(i,1), LDW ) ! BLAS CALL - ! ! W(i,1:N) = (ONE/WORK(i)) * W(i,1:N) ! INTRINSIC - !END DO - DO i = 1, K - WORK(N+i) = ONE/WORK(i) - END DO - DO j = 1, N - DO i = 1, K - W(i,j) = (WORK(N+i))*W(i,j) - END DO - END DO - END IF -! - IF ( WNTREF ) THEN - ! - ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) - ! for computing the refined Ritz vectors - ! (optionally, outside SGEDMD). - CALL SGEMM( 'N', T_OR_N, M, K, N, ONE, Y, LDY, W, & - LDW, ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' - ! - ! At this point Z contains - ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and - ! this is needed for computing the residuals. - ! This matrix is returned in the array B and - ! it can be used to compute refined Ritz vectors. - CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL - ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC - - CALL SGEMM( 'T', 'N', K, K, M, ONE, X, LDX, Z, & - LDZ, ZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC - ! At this point S = U^T * A * U is the Rayleigh quotient. - ELSE - ! A * U(:,1:K) is not explicitly needed and the - ! computation is organized differently. The Rayleigh - ! quotient is computed more efficiently. - CALL SGEMM( 'T', 'N', K, N, M, ONE, X, LDX, Y, LDY, & - ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC - ! In the two SGEMM calls here, can use K for LDZ - CALL SGEMM( 'N', T_OR_N, K, K, N, ONE, Z, LDZ, W, & - LDW, ZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' - ! At this point S = U^T * A * U is the Rayleigh quotient. - ! If the residuals are requested, save scaled V_k into Z. - ! Recall that V_k or V_k^T is stored in W. - IF ( WNTRES .OR. WNTEX ) THEN - IF ( LSAME(T_OR_N, 'N') ) THEN - CALL SLACPY( 'A', N, K, W, LDW, Z, LDZ ) - ELSE - CALL SLACPY( 'A', K, N, W, LDW, Z, LDZ ) - END IF - END IF - END IF -! - !<5> Compute the Ritz values and (if requested) the - ! right eigenvectors of the Rayleigh quotient. - ! - CALL SGEEV( 'N', JOBZL, K, S, LDS, REIG, IMEIG, W, & - LDW, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL - ! - ! W(1:K,1:K) contains the eigenvectors of the Rayleigh - ! quotient. Even in the case of complex spectrum, all - ! computation is done in real arithmetic. REIG and - ! IMEIG are the real and the imaginary parts of the - ! eigenvalues, so that the spectrum is given as - ! REIG(:) + sqrt(-1)*IMEIG(:). Complex conjugate pairs - ! are listed at consecutive positions. For such a - ! complex conjugate pair of the eigenvalues, the - ! corresponding eigenvectors are also a complex - ! conjugate pair with the real and imaginary parts - ! stored column-wise in W at the corresponding - ! consecutive column indices. See the description of Z. - ! Also, see the description of SGEEV. - IF ( INFO1 > 0 ) THEN - ! SGEEV failed to compute the eigenvalues and - ! eigenvectors of the Rayleigh quotient. - INFO = 3 - RETURN - END IF -! - ! <6> Compute the eigenvectors (if requested) and, - ! the residuals (if requested). - ! - IF ( WNTVEC .OR. WNTEX ) THEN - IF ( WNTRES ) THEN - IF ( WNTREF ) THEN - ! Here, if the refinement is requested, we have - ! A*U(:,1:K) already computed and stored in Z. - ! For the residuals, need Y = A * U(:,1;K) * W. - CALL SGEMM( 'N', 'N', M, K, K, ONE, Z, LDZ, W, & - LDW, ZERO, Y, LDY ) ! BLAS CALL - ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC - ! This frees Z; Y contains A * U(:,1:K) * W. - ELSE - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL SGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & - W, LDW, ZERO, S, LDS ) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - LDS, ZERO, Z, LDZ ) - ! Save a copy of Z into Y and free Z for holding - ! the Ritz vectors. - CALL SLACPY( 'A', M, K, Z, LDZ, Y, LDY ) - IF ( WNTEX ) CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF - ELSE IF ( WNTEX ) THEN - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL SGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & - W, LDW, ZERO, S, LDS ) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - LDS, ZERO, B, LDB ) - ! The above call replaces the following two calls - ! that were used in the developing-testing phase. - ! CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & - ! LDS, ZERO, Z, LDZ) - ! Save a copy of Z into B and free Z for holding - ! the Ritz vectors. - ! CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF -! - ! Compute the real form of the Ritz vectors - IF ( WNTVEC ) CALL SGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & - ZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC -! - IF ( WNTRES ) THEN - i = 1 - DO WHILE ( i <= K ) - IF ( IMEIG(i) == ZERO ) THEN - ! have a real eigenvalue with real eigenvector - CALL SAXPY( M, -REIG(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL - ! Y(1:M,i) = Y(1:M,i) - REIG(i) * Z(1:M,i) ! INTRINSIC - RES(i) = SNRM2( M, Y(1,i), 1 ) ! BLAS CALL - i = i + 1 - ELSE - ! Have a complex conjugate pair - ! REIG(i) +- sqrt(-1)*IMEIG(i). - ! Since all computation is done in real - ! arithmetic, the formula for the residual - ! is recast for real representation of the - ! complex conjugate eigenpair. See the - ! description of RES. - AB(1,1) = REIG(i) - AB(2,1) = -IMEIG(i) - AB(1,2) = IMEIG(i) - AB(2,2) = REIG(i) - CALL SGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & - LDZ, AB, 2, ONE, Y(1,i), LDY ) ! BLAS CALL - ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC - RES(i) = SLANGE( 'F', M, 2, Y(1,i), LDY, & - WORK(N+1) ) ! LAPACK CALL - RES(i+1) = RES(i) - i = i + 2 - END IF - END DO - END IF - END IF -! - IF ( WHTSVD == 4 ) THEN - WORK(N+1) = XSCL1 - WORK(N+2) = XSCL2 - END IF -! -! Successful exit. - IF ( .NOT. BADXY ) THEN - INFO = 0 - ELSE - ! A warning on possible data inconsistency. - ! This should be a rare event. - INFO = 4 - END IF -!............................................................ - RETURN -! ...... - END SUBROUTINE SGEDMD - +!> \brief \b SGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. +! +! =========== DOCUMENTATION =========== +! +! Definition: +! =========== +! +! SUBROUTINE SGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & +! M, N, X, LDX, Y, LDY, NRNK, TOL, & +! K, REIG, IMEIG, Z, LDZ, RES, & +! B, LDB, W, LDW, S, LDS, & +! WORK, LWORK, IWORK, LIWORK, INFO ) +!..... +! USE, INTRINSIC :: iso_fortran_env, only: real32 +! IMPLICIT NONE +! INTEGER, PARAMETER :: WP = real32 +!..... +! Scalar arguments +! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF +! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & +! NRNK, LDZ, LDB, LDW, LDS, & +! LWORK, LIWORK +! INTEGER, INTENT(OUT) :: K, INFO +! REAL(KIND=WP), INTENT(IN) :: TOL +! Array arguments +! REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) +! REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & +! W(LDW,*), S(LDS,*) +! REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & +! RES(*) +! REAL(KIND=WP), INTENT(OUT) :: WORK(*) +! INTEGER, INTENT(OUT) :: IWORK(*) +! +!............................................................ +!> \par Purpose: +! ============= +!> \verbatim +!> SGEDMD computes the Dynamic Mode Decomposition (DMD) for +!> a pair of data snapshot matrices. For the input matrices +!> X and Y such that Y = A*X with an unaccessible matrix +!> A, SGEDMD computes a certain number of Ritz pairs of A using +!> the standard Rayleigh-Ritz extraction from a subspace of +!> range(X) that is determined using the leading left singular +!> vectors of X. Optionally, SGEDMD returns the residuals +!> of the computed Ritz pairs, the information needed for +!> a refinement of the Ritz vectors, or the eigenvectors of +!> the Exact DMD. +!> For further details see the references listed +!> below. For more details of the implementation see [3]. +!> \endverbatim +!............................................................ +!> \par References: +! ================ +!> \verbatim +!> [1] P. Schmid: Dynamic mode decomposition of numerical +!> and experimental data, +!> Journal of Fluid Mechanics 656, 5-28, 2010. +!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal +!> decompositions: analysis and enhancements, +!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. +!> [3] Z. Drmac: A LAPACK implementation of the Dynamic +!> Mode Decomposition I. Technical report. AIMDyn Inc. +!> and LAPACK Working Note 298. +!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. +!> Brunton, N. Kutz: On Dynamic Mode Decomposition: +!> Theory and Applications, Journal of Computational +!> Dynamics 1(2), 391 -421, 2014. +!> \endverbatim +!...................................................................... +!> \par Developed and supported by: +! ================================ +!> \verbatim +!> Developed and coded by Zlatko Drmac, Faculty of Science, +!> University of Zagreb; drmac@math.hr +!> In cooperation with +!> AIMdyn Inc., Santa Barbara, CA. +!> and supported by +!> - DARPA SBIR project "Koopman Operator-Based Forecasting +!> for Nonstationary Processes from Near-Term, Limited +!> Observational Data" Contract No: W31P4Q-21-C-0007 +!> - DARPA PAI project "Physics-Informed Machine Learning +!> Methodologies" Contract No: HR0011-18-9-0033 +!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic +!> Framework for Space-Time Analysis of Process Dynamics" +!> Contract No: HR0011-16-C-0116 +!> Any opinions, findings and conclusions or recommendations +!> expressed in this material are those of the author and +!> do not necessarily reflect the views of the DARPA SBIR +!> Program Office +!> \endverbatim +!...................................................................... +!> \par Distribution Statement A: +! ============================== +!> \verbatim +!> Distribution Statement A: +!> Approved for Public Release, Distribution Unlimited. +!> Cleared by DARPA on September 29, 2022 +!> \endverbatim +!============================================================ +! Arguments +! ========= +! +!> \param[in] JOBS +!> \verbatim +!> JOBS (input) CHARACTER*1 +!> Determines whether the initial data snapshots are scaled +!> by a diagonal matrix. +!> 'S' :: The data snapshots matrices X and Y are multiplied +!> with a diagonal matrix D so that X*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'C' :: The snapshots are scaled as with the 'S' option. +!> If it is found that an i-th column of X is zero +!> vector and the corresponding i-th column of Y is +!> non-zero, then the i-th column of Y is set to +!> zero and a warning flag is raised. +!> 'Y' :: The data snapshots matrices X and Y are multiplied +!> by a diagonal matrix D so that Y*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'N' :: No data scaling. +!> \endverbatim +!..... +!> \param[in] JOBZ +!> \verbatim +!> JOBZ (input) CHARACTER*1 +!> Determines whether the eigenvectors (Koopman modes) will +!> be computed. +!> 'V' :: The eigenvectors (Koopman modes) will be computed +!> and returned in the matrix Z. +!> See the description of Z. +!> 'F' :: The eigenvectors (Koopman modes) will be returned +!> in factored form as the product X(:,1:K)*W, where X +!> contains a POD basis (leading left singular vectors +!> of the data matrix X) and W contains the eigenvectors +!> of the corresponding Rayleigh quotient. +!> See the descriptions of K, X, W, Z. +!> 'N' :: The eigenvectors are not computed. +!> \endverbatim +!..... +!> \param[in] JOBR +!> \verbatim +!> JOBR (input) CHARACTER*1 +!> Determines whether to compute the residuals. +!> 'R' :: The residuals for the computed eigenpairs will be +!> computed and stored in the array RES. +!> See the description of RES. +!> For this option to be legal, JOBZ must be 'V'. +!> 'N' :: The residuals are not computed. +!> \endverbatim +!..... +!> \param[in] JOBF +!> \verbatim +!> JOBF (input) CHARACTER*1 +!> Specifies whether to store information needed for post- +!> processing (e.g. computing refined Ritz vectors) +!> 'R' :: The matrix needed for the refinement of the Ritz +!> vectors is computed and stored in the array B. +!> See the description of B. +!> 'E' :: The unscaled eigenvectors of the Exact DMD are +!> computed and returned in the array B. See the +!> description of B. +!> 'N' :: No eigenvector refinement data is computed. +!> \endverbatim +!..... +!> \param[in] WHTSVD +!> \verbatim +!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } +!> Allows for a selection of the SVD algorithm from the +!> LAPACK library. +!> 1 :: SGESVD (the QR SVD algorithm) +!> 2 :: SGESDD (the Divide and Conquer algorithm; if enough +!> workspace available, this is the fastest option) +!> 3 :: SGESVDQ (the preconditioned QR SVD ; this and 4 +!> are the most accurate options) +!> 4 :: SGEJSV (the preconditioned Jacobi SVD; this and 3 +!> are the most accurate options) +!> For the four methods above, a significant difference in +!> the accuracy of small singular values is possible if +!> the snapshots vary in norm so that X is severely +!> ill-conditioned. If small (smaller than EPS*||X||) +!> singular values are of interest and JOBS=='N', then +!> the options (3, 4) give the most accurate results, where +!> the option 4 is slightly better and with stronger +!> theoretical background. +!> If JOBS=='S', i.e. the columns of X will be normalized, +!> then all methods give nearly equally accurate results. +!> \endverbatim +!..... +!> \param[in] M +!> \verbatim +!> M (input) INTEGER, M>= 0 +!> The state space dimension (the row dimension of X, Y). +!> \endverbatim +!..... +!> \param[in] N +!> \verbatim +!> N (input) INTEGER, 0 <= N <= M +!> The number of data snapshot pairs +!> (the number of columns of X and Y). +!> \endverbatim +!..... +!> \param[in,out] X +!> \verbatim +!> X (input/output) REAL(KIND=WP) M-by-N array +!> > On entry, X contains the data snapshot matrix X. It is +!> assumed that the column norms of X are in the range of +!> the normalized floating point numbers. +!> < On exit, the leading K columns of X contain a POD basis, +!> i.e. the leading K left singular vectors of the input +!> data matrix X, U(:,1:K). All N columns of X contain all +!> left singular vectors of the input matrix X. +!> See the descriptions of K, Z and W. +!> \endverbatim +!..... +!> \param[in] LDX +!> \verbatim +!> LDX (input) INTEGER, LDX >= M +!> The leading dimension of the array X. +!> \endverbatim +!..... +!> \param[in,out] Y +!> \verbatim +!> Y (input/workspace/output) REAL(KIND=WP) M-by-N array +!> > On entry, Y contains the data snapshot matrix Y +!> < On exit, +!> If JOBR == 'R', the leading K columns of Y contain +!> the residual vectors for the computed Ritz pairs. +!> See the description of RES. +!> If JOBR == 'N', Y contains the original input data, +!> scaled according to the value of JOBS. +!> \endverbatim +!..... +!> \param[in] LDY +!> \verbatim +!> LDY (input) INTEGER , LDY >= M +!> The leading dimension of the array Y. +!> \endverbatim +!..... +!> \param[in] NRNK +!> \verbatim +!> NRNK (input) INTEGER +!> Determines the mode how to compute the numerical rank, +!> i.e. how to truncate small singular values of the input +!> matrix X. On input, if +!> NRNK = -1 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(1) +!> This option is recommended. +!> NRNK = -2 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(i-1) +!> This option is included for R&D purposes. +!> It requires highly accurate SVD, which +!> may not be feasible. +!> The numerical rank can be enforced by using positive +!> value of NRNK as follows: +!> 0 < NRNK <= N :: at most NRNK largest singular values +!> will be used. If the number of the computed nonzero +!> singular values is less than NRNK, then only those +!> nonzero values will be used and the actually used +!> dimension is less than NRNK. The actual number of +!> the nonzero singular values is returned in the variable +!> K. See the descriptions of TOL and K. +!> \endverbatim +!..... +!> \param[in] TOL +!> \verbatim +!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 +!> The tolerance for truncating small singular values. +!> See the description of NRNK. +!> \endverbatim +!..... +!> \param[out] K +!> \verbatim +!> K (output) INTEGER, 0 <= K <= N +!> The dimension of the POD basis for the data snapshot +!> matrix X and the number of the computed Ritz pairs. +!> The value of K is determined according to the rule set +!> by the parameters NRNK and TOL. +!> See the descriptions of NRNK and TOL. +!> \endverbatim +!..... +!> \param[out] REIG +!> \verbatim +!> REIG (output) REAL(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of REIG contain +!> the real parts of the computed eigenvalues +!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). +!> See the descriptions of K, IMEIG, and Z. +!> \endverbatim +!..... +!> \param[out] IMEIG +!> \verbatim +!> IMEIG (output) REAL(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of IMEIG contain +!> the imaginary parts of the computed eigenvalues +!> REIG(1:K) + sqrt(-1)*IMEIG(1:K). +!> The eigenvalues are determined as follows: +!> If IMEIG(i) == 0, then the corresponding eigenvalue is +!> real, LAMBDA(i) = REIG(i). +!> If IMEIG(i)>0, then the corresponding complex +!> conjugate pair of eigenvalues reads +!> LAMBDA(i) = REIG(i) + sqrt(-1)*IMAG(i) +!> LAMBDA(i+1) = REIG(i) - sqrt(-1)*IMAG(i) +!> That is, complex conjugate pairs have consecutive +!> indices (i,i+1), with the positive imaginary part +!> listed first. +!> See the descriptions of K, REIG, and Z. +!> \endverbatim +!..... +!> \param[out] Z +!> \verbatim +!> Z (workspace/output) REAL(KIND=WP) M-by-N array +!> If JOBZ =='V' then +!> Z contains real Ritz vectors as follows: +!> If IMEIG(i)=0, then Z(:,i) is an eigenvector of +!> the i-th Ritz value; ||Z(:,i)||_2=1. +!> If IMEIG(i) > 0 (and IMEIG(i+1) < 0) then +!> [Z(:,i) Z(:,i+1)] span an invariant subspace and +!> the Ritz values extracted from this subspace are +!> REIG(i) + sqrt(-1)*IMEIG(i) and +!> REIG(i) - sqrt(-1)*IMEIG(i). +!> The corresponding eigenvectors are +!> Z(:,i) + sqrt(-1)*Z(:,i+1) and +!> Z(:,i) - sqrt(-1)*Z(:,i+1), respectively. +!> || Z(:,i:i+1)||_F = 1. +!> If JOBZ == 'F', then the above descriptions hold for +!> the columns of X(:,1:K)*W(1:K,1:K), where the columns +!> of W(1:k,1:K) are the computed eigenvectors of the +!> K-by-K Rayleigh quotient. The columns of W(1:K,1:K) +!> are similarly structured: If IMEIG(i) == 0 then +!> X(:,1:K)*W(:,i) is an eigenvector, and if IMEIG(i)>0 +!> then X(:,1:K)*W(:,i)+sqrt(-1)*X(:,1:K)*W(:,i+1) and +!> X(:,1:K)*W(:,i)-sqrt(-1)*X(:,1:K)*W(:,i+1) +!> are the eigenvectors of LAMBDA(i), LAMBDA(i+1). +!> See the descriptions of REIG, IMEIG, X and W. +!> \endverbatim +!..... +!> \param[in] LDZ +!> \verbatim +!> LDZ (input) INTEGER , LDZ >= M +!> The leading dimension of the array Z. +!> \endverbatim +!..... +!> \param[out] RES +!> \verbatim +!> RES (output) REAL(KIND=WP) N-by-1 array +!> RES(1:K) contains the residuals for the K computed +!> Ritz pairs. +!> If LAMBDA(i) is real, then +!> RES(i) = || A * Z(:,i) - LAMBDA(i)*Z(:,i))||_2. +!> If [LAMBDA(i), LAMBDA(i+1)] is a complex conjugate pair +!> then +!> RES(i)=RES(i+1) = || A * Z(:,i:i+1) - Z(:,i:i+1) *B||_F +!> where B = [ real(LAMBDA(i)) imag(LAMBDA(i)) ] +!> [-imag(LAMBDA(i)) real(LAMBDA(i)) ]. +!> It holds that +!> RES(i) = || A*ZC(:,i) - LAMBDA(i) *ZC(:,i) ||_2 +!> RES(i+1) = || A*ZC(:,i+1) - LAMBDA(i+1)*ZC(:,i+1) ||_2 +!> where ZC(:,i) = Z(:,i) + sqrt(-1)*Z(:,i+1) +!> ZC(:,i+1) = Z(:,i) - sqrt(-1)*Z(:,i+1) +!> See the description of REIG, IMEIG and Z. +!> \endverbatim +!..... +!> \param[out] B +!> \verbatim +!> B (output) REAL(KIND=WP) M-by-N array. +!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can +!> be used for computing the refined vectors; see further +!> details in the provided references. +!> If JOBF == 'E', B(1:M,1;K) contains +!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the +!> Exact DMD, up to scaling by the inverse eigenvalues. +!> If JOBF =='N', then B is not referenced. +!> See the descriptions of X, W, K. +!> \endverbatim +!..... +!> \param[in] LDB +!> \verbatim +!> LDB (input) INTEGER, LDB >= M +!> The leading dimension of the array B. +!> \endverbatim +!..... +!> \param[out] W +!> \verbatim +!> W (workspace/output) REAL(KIND=WP) N-by-N array +!> On exit, W(1:K,1:K) contains the K computed +!> eigenvectors of the matrix Rayleigh quotient (real and +!> imaginary parts for each complex conjugate pair of the +!> eigenvalues). The Ritz vectors (returned in Z) are the +!> product of X (containing a POD basis for the input +!> matrix X) and W. See the descriptions of K, S, X and Z. +!> W is also used as a workspace to temporarily store the +!> left singular vectors of X. +!> \endverbatim +!..... +!> \param[in] LDW +!> \verbatim +!> LDW (input) INTEGER, LDW >= N +!> The leading dimension of the array W. +!> \endverbatim +!..... +!> \param[out] S +!> \verbatim +!> S (workspace/output) REAL(KIND=WP) N-by-N array +!> The array S(1:K,1:K) is used for the matrix Rayleigh +!> quotient. This content is overwritten during +!> the eigenvalue decomposition by SGEEV. +!> See the description of K. +!> \endverbatim +!..... +!> \param[in] LDS +!> \verbatim +!> LDS (input) INTEGER, LDS >= N +!> The leading dimension of the array S. +!> \endverbatim +!..... +!> \param[out] WORK +!> \verbatim +!> WORK (workspace/output) REAL(KIND=WP) LWORK-by-1 array +!> On exit, WORK(1:N) contains the singular values of +!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). +!> If WHTSVD==4, then WORK(N+1) and WORK(N+2) contain +!> scaling factor WORK(N+2)/WORK(N+1) used to scale X +!> and Y to avoid overflow in the SVD of X. +!> This may be of interest if the scaling option is off +!> and as many as possible smallest eigenvalues are +!> desired to the highest feasible accuracy. +!> If the call to SGEDMD is only workspace query, then +!> WORK(1) contains the minimal workspace length and +!> WORK(2) is the optimal workspace length. Hence, the +!> length of work is at least 2. +!> See the description of LWORK. +!> \endverbatim +!..... +!> \param[in] LWORK +!> \verbatim +!> LWORK (input) INTEGER +!> The minimal length of the workspace vector WORK. +!> LWORK is calculated as follows: +!> If WHTSVD == 1 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)). +!> If JOBZ == 'N' then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)). +!> Here LWORK_SVD = MAX(1,3*N+M,5*N) is the minimal +!> workspace length of SGESVD. +!> If WHTSVD == 2 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N + LWORK_SVD, N+MAX(1,3*N)) +!> Here LWORK_SVD = MAX(M, 5*N*N+4*N)+3*N*N is the +!> minimal workspace length of SGESDD. +!> If WHTSVD == 3 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) +!> Here LWORK_SVD = N+M+MAX(3*N+1, +!> MAX(1,3*N+M,5*N),MAX(1,N)) +!> is the minimal workspace length of SGESVDQ. +!> If WHTSVD == 4 :: +!> If JOBZ == 'V', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,4*N)) +!> If JOBZ == 'N', then +!> LWORK >= MAX(2, N+LWORK_SVD,N+MAX(1,3*N)) +!> Here LWORK_SVD = MAX(7,2*M+N,6*N+2*N*N) is the +!> minimal workspace length of SGEJSV. +!> The above expressions are not simplified in order to +!> make the usage of WORK more transparent, and for +!> easier checking. In any case, LWORK >= 2. +!> If on entry LWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for both WORK and +!> IWORK. See the descriptions of WORK and IWORK. +!> \endverbatim +!..... +!> \param[out] IWORK +!> \verbatim +!> IWORK (workspace/output) INTEGER LIWORK-by-1 array +!> Workspace that is required only if WHTSVD equals +!> 2 , 3 or 4. (See the description of WHTSVD). +!> If on entry LWORK =-1 or LIWORK=-1, then the +!> minimal length of IWORK is computed and returned in +!> IWORK(1). See the description of LIWORK. +!> \endverbatim +!..... +!> \param[in] LIWORK +!> \verbatim +!> LIWORK (input) INTEGER +!> The minimal length of the workspace vector IWORK. +!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 +!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) +!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) +!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) +!> If on entry LIWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for both WORK and +!> IWORK. See the descriptions of WORK and IWORK. +!> \endverbatim +!..... +!> \param[out] INFO +!> \verbatim +!> INFO (output) INTEGER +!> -i < 0 :: On entry, the i-th argument had an +!> illegal value +!> = 0 :: Successful return. +!> = 1 :: Void input. Quick exit (M=0 or N=0). +!> = 2 :: The SVD computation of X did not converge. +!> Suggestion: Check the input data and/or +!> repeat with different WHTSVD. +!> = 3 :: The computation of the eigenvalues did not +!> converge. +!> = 4 :: If data scaling was requested on input and +!> the procedure found inconsistency in the data +!> such that for some column index i, +!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set +!> to zero if JOBS=='C'. The computation proceeds +!> with original or modified data and warning +!> flag is set with INFO=4. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Zlatko Drmac +! +!> \ingroup gedmd +! +!............................................................. +!............................................................. + SUBROUTINE SGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, REIG, IMEIG, Z, LDZ, RES, & + B, LDB, W, LDW, S, LDS, & + WORK, LWORK, IWORK, LIWORK, INFO ) +! +! -- LAPACK driver routine -- +! +! -- LAPACK is a software package provided by University of -- +! -- Tennessee, University of California Berkeley, University of -- +! -- Colorado Denver and NAG Ltd.. -- +! +!..... + USE, INTRINSIC :: iso_fortran_env, only: real32 + IMPLICIT NONE + INTEGER, PARAMETER :: WP = real32 +! +! Scalar arguments +! ~~~~~~~~~~~~~~~~ + CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF + INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & + NRNK, LDZ, LDB, LDW, LDS, & + LWORK, LIWORK + INTEGER, INTENT(OUT) :: K, INFO + REAL(KIND=WP), INTENT(IN) :: TOL +! +! Array arguments +! ~~~~~~~~~~~~~~~ + REAL(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) + REAL(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & + W(LDW,*), S(LDS,*) + REAL(KIND=WP), INTENT(OUT) :: REIG(*), IMEIG(*), & + RES(*) + REAL(KIND=WP), INTENT(OUT) :: WORK(*) + INTEGER, INTENT(OUT) :: IWORK(*) +! +! Parameters +! ~~~~~~~~~~ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP +! +! Local scalars +! ~~~~~~~~~~~~~ + REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & + SSUM, XSCL1, XSCL2, TBIG + INTEGER :: i, j, IMINWR, INFO1, INFO2, & + LWRKEV, LWRSDD, LWRSVD, & + LWRSVQ, MLWORK, MWRKEV, MWRSDD, & + MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & + OLWORK + LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & + WNTEX, WNTREF, WNTRES, WNTVEC + CHARACTER :: JOBZL, T_OR_N + CHARACTER :: JSVOPT +! +! Local arrays +! ~~~~~~~~~~~~ + REAL(KIND=WP) :: AB(2,2), RDUMMY(2), RDUMMY2(2) +! +! External functions (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~ + REAL(KIND=WP) SLANGE, SLAMCH, SNRM2 + EXTERNAL SLANGE, SLAMCH, SNRM2, ISAMAX + INTEGER ISAMAX + LOGICAL SISNAN, LSAME + EXTERNAL SISNAN, LSAME +! +! External subroutines (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~~~~ + EXTERNAL SAXPY, SGEMM, SSCAL + EXTERNAL SGEEV, SGEJSV, SGESDD, SGESVD, SGESVDQ, & + SLACPY, SLASCL, SLASSQ, XERBLA +! +! Intrinsic functions +! ~~~~~~~~~~~~~~~~~~~ + INTRINSIC INT, FLOAT, MAX, SQRT +!............................................................ +! +! Test the input arguments +! + WNTRES = LSAME(JOBR,'R') + SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') + SCCOLY = LSAME(JOBS,'Y') + WNTVEC = LSAME(JOBZ,'V') + WNTREF = LSAME(JOBF,'R') + WNTEX = LSAME(JOBF,'E') + INFO = 0 + LQUERY = ( ( LWORK == -1 ) .OR. ( LIWORK == -1 ) ) +! + IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & + LSAME(JOBS,'N')) ) THEN + INFO = -1 + ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & + .OR. LSAME(JOBZ,'F')) ) THEN + INFO = -2 + ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & + ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN + INFO = -3 + ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & + LSAME(JOBF,'N') ) ) THEN + INFO = -4 + ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & + (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN + INFO = -5 + ELSE IF ( M < 0 ) THEN + INFO = -6 + ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN + INFO = -7 + ELSE IF ( LDX < M ) THEN + INFO = -9 + ELSE IF ( LDY < M ) THEN + INFO = -11 + ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & + ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN + INFO = -12 + ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN + INFO = -13 + ELSE IF ( LDZ < M ) THEN + INFO = -18 + ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN + INFO = -21 + ELSE IF ( LDW < N ) THEN + INFO = -23 + ELSE IF ( LDS < N ) THEN + INFO = -25 + END IF +! + IF ( INFO == 0 ) THEN + ! Compute the minimal and the optimal workspace + ! requirements. Simulate running the code and + ! determine minimal and optimal sizes of the + ! workspace at any moment of the run. + IF ( N == 0 ) THEN + ! Quick return. All output except K is void. + ! INFO=1 signals the void input. + ! In case of a workspace query, the default + ! minimal workspace lengths are returned. + IF ( LQUERY ) THEN + IWORK(1) = 1 + WORK(1) = 2 + WORK(2) = 2 + ELSE + K = 0 + END IF + INFO = 1 + RETURN + END IF + MLWORK = MAX(2,N) + OLWORK = MAX(2,N) + IMINWR = 1 + SELECT CASE ( WHTSVD ) + CASE (1) + ! The following is specified as the minimal + ! length of WORK in the definition of SGESVD: + ! MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + MLWORK = MAX(MLWORK,N + MWRSVD) + IF ( LQUERY ) THEN + CALL SGESVD( 'O', 'S', M, N, X, LDX, WORK, & + B, LDB, W, LDW, RDUMMY, -1, INFO1 ) + LWRSVD = MAX( MWRSVD, INT( RDUMMY(1) ) ) + OLWORK = MAX(OLWORK,N + LWRSVD) + END IF + CASE (2) + ! The following is specified as the minimal + ! length of WORK in the definition of SGESDD: + ! MWRSDD = 3*MIN(M,N)*MIN(M,N) + + ! MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) + ! IMINWR = 8*MIN(M,N) + MWRSDD = 3*MIN(M,N)*MIN(M,N) + & + MAX( MAX(M,N),5*MIN(M,N)*MIN(M,N)+4*MIN(M,N) ) + MLWORK = MAX(MLWORK,N + MWRSDD) + IMINWR = 8*MIN(M,N) + IF ( LQUERY ) THEN + CALL SGESDD( 'O', M, N, X, LDX, WORK, B, & + LDB, W, LDW, RDUMMY, -1, IWORK, INFO1 ) + LWRSDD = MAX( MWRSDD, INT( RDUMMY(1) ) ) + OLWORK = MAX(OLWORK,N + LWRSDD) + END IF + CASE (3) + !LWQP3 = 3*N+1 + !LWORQ = MAX(N, 1) + !MWRSVD = MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + !MWRSVQ = N + MAX( LWQP3, MWRSVD, LWORQ )+ MAX(M,2) + !MLWORK = N + MWRSVQ + !IMINWR = M+N-1 + CALL SGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, WORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, -1, RDUMMY, & + -1, RDUMMY2, -1, INFO1 ) + IMINWR = IWORK(1) + MWRSVQ = INT(RDUMMY(2)) + MLWORK = MAX(MLWORK,N+MWRSVQ+INT(RDUMMY2(1))) + IF ( LQUERY ) THEN + LWRSVQ = INT(RDUMMY(1)) + OLWORK = MAX(OLWORK,N+LWRSVQ+INT(RDUMMY2(1))) + END IF + CASE (4) + JSVOPT = 'J' + !MWRSVJ = MAX( 7, 2*M+N, 6*N+2*N*N )! for JSVOPT='V' + MWRSVJ = MAX( 7, 2*M+N, 4*N+N*N, 2*N+N*N+6 ) + MLWORK = MAX(MLWORK,N+MWRSVJ) + IMINWR = MAX( 3, M+3*N ) + IF ( LQUERY ) THEN + OLWORK = MAX(OLWORK,N+MWRSVJ) + END IF + END SELECT + IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN + JOBZL = 'V' + ELSE + JOBZL = 'N' + END IF + ! Workspace calculation to the SGEEV call + IF ( LSAME(JOBZL,'V') ) THEN + MWRKEV = MAX( 1, 4*N ) + ELSE + MWRKEV = MAX( 1, 3*N ) + END IF + MLWORK = MAX(MLWORK,N+MWRKEV) + IF ( LQUERY ) THEN + CALL SGEEV( 'N', JOBZL, N, S, LDS, REIG, & + IMEIG, W, LDW, W, LDW, RDUMMY, -1, INFO1 ) + LWRKEV = MAX( MWRKEV, INT(RDUMMY(1)) ) + OLWORK = MAX( OLWORK, N+LWRKEV ) + END IF +! + IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -29 + IF ( LWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -27 + END IF +! + IF( INFO /= 0 ) THEN + CALL XERBLA( 'SGEDMD', -INFO ) + RETURN + ELSE IF ( LQUERY ) THEN +! Return minimal and optimal workspace sizes + IWORK(1) = IMINWR + WORK(1) = REAL(MLWORK) + WORK(2) = REAL(OLWORK) + RETURN + END IF +!............................................................ +! + OFL = SLAMCH('O') + SMALL = SLAMCH('S') + BADXY = .FALSE. +! +! <1> Optional scaling of the snapshots (columns of X, Y) +! ========================================================== + IF ( SCCOLX ) THEN + ! The columns of X will be normalized. + ! To prevent overflows, the column norms of X are + ! carefully computed using SLASSQ. + K = 0 + DO i = 1, N + !WORK(i) = DNRM2( M, X(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL SLASSQ( M, X(1,i), 1, SCALE, SSUM ) + IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN + K = 0 + INFO = -8 + CALL XERBLA('SGEDMD',-INFO) + END IF + IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of X(:,i) overflows. First, X(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. +! Next, the norm of X(:,i) is stored without +! overflow as WORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of X(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL SLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, X(1,i), M, INFO2 ) + WORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + WORK(i) = SCALE * ROOTSC + CALL SLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & + X(1,i), M, INFO2 ) ! LAPACK CALL +! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC + END IF + ELSE + WORK(i) = ZERO + K = K + 1 + END IF + END DO + IF ( K == N ) THEN + ! All columns of X are zero. Return error code -8. + ! (the 8th input variable had an illegal value) + K = 0 + INFO = -8 + CALL XERBLA('SGEDMD',-INFO) + RETURN + END IF + DO i = 1, N +! Now, apply the same scaling to the columns of Y. + IF ( WORK(i) > ZERO ) THEN + CALL SSCAL( M, ONE/WORK(i), Y(1,i), 1 ) ! BLAS CALL +! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC + ELSE IF ( WORK(i) < ZERO ) THEN + CALL SLASCL( 'G', 0, 0, -WORK(i), & + ONE/FLOAT(M), M, 1, Y(1,i), M, INFO2 ) ! LAPACK CALL + ELSE IF ( Y(ISAMAX(M, Y(1,i),1),i ) & + /= ZERO ) THEN +! X(:,i) is zero vector. For consistency, +! Y(:,i) should also be zero. If Y(:,i) is not +! zero, then the data might be inconsistent or +! corrupted. If JOBS == 'C', Y(:,i) is set to +! zero and a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + IF ( LSAME(JOBS,'C')) & + CALL SSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL + END IF + END DO + END IF + ! + IF ( SCCOLY ) THEN + ! The columns of Y will be normalized. + ! To prevent overflows, the column norms of Y are + ! carefully computed using SLASSQ. + DO i = 1, N + !WORK(i) = DNRM2( M, Y(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL SLASSQ( M, Y(1,i), 1, SCALE, SSUM ) + IF ( SISNAN(SCALE) .OR. SISNAN(SSUM) ) THEN + K = 0 + INFO = -10 + CALL XERBLA('SGEDMD',-INFO) + END IF + IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of Y(:,i) overflows. First, Y(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. +! Next, the norm of Y(:,i) is stored without +! overflow as WORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of Y(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL SLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, Y(1,i), M, INFO2 ) + WORK(i) = - SCALE * ( ROOTSC / FLOAT(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + WORK(i) = SCALE * ROOTSC + CALL SLASCL( 'G',0, 0, WORK(i), ONE, M, 1, & + Y(1,i), M, INFO2 ) ! LAPACK CALL +! Y(1:M,i) = (ONE/WORK(i)) * Y(1:M,i) ! INTRINSIC + END IF + ELSE + WORK(i) = ZERO + END IF + END DO + DO i = 1, N +! Now, apply the same scaling to the columns of X. + IF ( WORK(i) > ZERO ) THEN + CALL SSCAL( M, ONE/WORK(i), X(1,i), 1 ) ! BLAS CALL +! X(1:M,i) = (ONE/WORK(i)) * X(1:M,i) ! INTRINSIC + ELSE IF ( WORK(i) < ZERO ) THEN + CALL SLASCL( 'G', 0, 0, -WORK(i), & + ONE/FLOAT(M), M, 1, X(1,i), M, INFO2 ) ! LAPACK CALL + ELSE IF ( X(ISAMAX(M, X(1,i),1),i ) & + /= ZERO ) THEN +! Y(:,i) is zero vector. If X(:,i) is not +! zero, then a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + END IF + END DO + END IF +! +! <2> SVD of the data snapshot matrix X. +! ===================================== +! The left singular vectors are stored in the array X. +! The right singular vectors are in the array W. +! The array W will later on contain the eigenvectors +! of a Rayleigh quotient. + NUMRNK = N + SELECT CASE ( WHTSVD ) + CASE (1) + CALL SGESVD( 'O', 'S', M, N, X, LDX, WORK, B, & + LDB, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL + T_OR_N = 'T' + CASE (2) + CALL SGESDD( 'O', M, N, X, LDX, WORK, B, LDB, W, & + LDW, WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL + T_OR_N = 'T' + CASE (3) + CALL SGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, WORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, LIWORK, WORK(N+MAX(2,M)+1),& + LWORK-N-MAX(2,M), WORK(N+1), MAX(2,M), INFO1) ! LAPACK CALL + CALL SLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'T' + CASE (4) + CALL SGEJSV( 'F', 'U', JSVOPT, 'N', 'N', 'P', M, & + N, X, LDX, WORK, Z, LDZ, W, LDW, & + WORK(N+1), LWORK-N, IWORK, INFO1 ) ! LAPACK CALL + CALL SLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'N' + XSCL1 = WORK(N+1) + XSCL2 = WORK(N+2) + IF ( XSCL1 /= XSCL2 ) THEN + ! This is an exceptional situation. If the + ! data matrices are not scaled and the + ! largest singular value of X overflows. + ! In that case SGEJSV can return the SVD + ! in scaled form. The scaling factor can be used + ! to rescale the data (X and Y). + CALL SLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) + END IF + END SELECT +! + IF ( INFO1 > 0 ) THEN + ! The SVD selected subroutine did not converge. + ! Return with an error code. + INFO = 2 + RETURN + END IF +! + IF ( WORK(1) == ZERO ) THEN + ! The largest computed singular value of (scaled) + ! X is zero. Return error code -8 + ! (the 8th input variable had an illegal value). + K = 0 + INFO = -8 + CALL XERBLA('SGEDMD',-INFO) + RETURN + END IF +! + !<3> Determine the numerical rank of the data + ! snapshots matrix X. This depends on the + ! parameters NRNK and TOL. + + SELECT CASE ( NRNK ) + CASE ( -1 ) + K = 1 + DO i = 2, NUMRNK + IF ( ( WORK(i) <= WORK(1)*TOL ) .OR. & + ( WORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE ( -2 ) + K = 1 + DO i = 1, NUMRNK-1 + IF ( ( WORK(i+1) <= WORK(i)*TOL ) .OR. & + ( WORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE DEFAULT + K = 1 + DO i = 2, NRNK + IF ( WORK(i) <= SMALL ) EXIT + K = K + 1 + END DO + END SELECT + ! Now, U = X(1:M,1:K) is the SVD/POD basis for the + ! snapshot data in the input matrix X. + + !<4> Compute the Rayleigh quotient S = U^T * A * U. + ! Depending on the requested outputs, the computation + ! is organized to compute additional auxiliary + ! matrices (for the residuals and refinements). + ! + ! In all formulas below, we need V_k*Sigma_k^(-1) + ! where either V_k is in W(1:N,1:K), or V_k^T is in + ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). + IF ( LSAME(T_OR_N, 'N') ) THEN + DO i = 1, K + CALL SSCAL( N, ONE/WORK(i), W(1,i), 1 ) ! BLAS CALL + ! W(1:N,i) = (ONE/WORK(i)) * W(1:N,i) ! INTRINSIC + END DO + ELSE + ! This non-unit stride access is due to the fact + ! that SGESVD, SGESVDQ and SGESDD return the + ! transposed matrix of the right singular vectors. + !DO i = 1, K + ! CALL SSCAL( N, ONE/WORK(i), W(i,1), LDW ) ! BLAS CALL + ! ! W(i,1:N) = (ONE/WORK(i)) * W(i,1:N) ! INTRINSIC + !END DO + DO i = 1, K + WORK(N+i) = ONE/WORK(i) + END DO + DO j = 1, N + DO i = 1, K + W(i,j) = (WORK(N+i))*W(i,j) + END DO + END DO + END IF +! + IF ( WNTREF ) THEN + ! + ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) + ! for computing the refined Ritz vectors + ! (optionally, outside SGEDMD). + CALL SGEMM( 'N', T_OR_N, M, K, N, ONE, Y, LDY, W, & + LDW, ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' + ! + ! At this point Z contains + ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and + ! this is needed for computing the residuals. + ! This matrix is returned in the array B and + ! it can be used to compute refined Ritz vectors. + CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL + ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC + + CALL SGEMM( 'T', 'N', K, K, M, ONE, X, LDX, Z, & + LDZ, ZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(TANSPOSE(X(1:M,1:K)),Z(1:M,1:K)) ! INTRINSIC + ! At this point S = U^T * A * U is the Rayleigh quotient. + ELSE + ! A * U(:,1:K) is not explicitly needed and the + ! computation is organized differently. The Rayleigh + ! quotient is computed more efficiently. + CALL SGEMM( 'T', 'N', K, N, M, ONE, X, LDX, Y, LDY, & + ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:K,1:N) = MATMUL( TRANSPOSE(X(1:M,1:K)), Y(1:M,1:N) ) ! INTRINSIC + ! In the two SGEMM calls here, can use K for LDZ + CALL SGEMM( 'N', T_OR_N, K, K, N, ONE, Z, LDZ, W, & + LDW, ZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(W(1:K,1:N))) ! INTRINSIC, for T_OR_N=='T' + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' + ! At this point S = U^T * A * U is the Rayleigh quotient. + ! If the residuals are requested, save scaled V_k into Z. + ! Recall that V_k or V_k^T is stored in W. + IF ( WNTRES .OR. WNTEX ) THEN + IF ( LSAME(T_OR_N, 'N') ) THEN + CALL SLACPY( 'A', N, K, W, LDW, Z, LDZ ) + ELSE + CALL SLACPY( 'A', K, N, W, LDW, Z, LDZ ) + END IF + END IF + END IF +! + !<5> Compute the Ritz values and (if requested) the + ! right eigenvectors of the Rayleigh quotient. + ! + CALL SGEEV( 'N', JOBZL, K, S, LDS, REIG, IMEIG, W, & + LDW, W, LDW, WORK(N+1), LWORK-N, INFO1 ) ! LAPACK CALL + ! + ! W(1:K,1:K) contains the eigenvectors of the Rayleigh + ! quotient. Even in the case of complex spectrum, all + ! computation is done in real arithmetic. REIG and + ! IMEIG are the real and the imaginary parts of the + ! eigenvalues, so that the spectrum is given as + ! REIG(:) + sqrt(-1)*IMEIG(:). Complex conjugate pairs + ! are listed at consecutive positions. For such a + ! complex conjugate pair of the eigenvalues, the + ! corresponding eigenvectors are also a complex + ! conjugate pair with the real and imaginary parts + ! stored column-wise in W at the corresponding + ! consecutive column indices. See the description of Z. + ! Also, see the description of SGEEV. + IF ( INFO1 > 0 ) THEN + ! SGEEV failed to compute the eigenvalues and + ! eigenvectors of the Rayleigh quotient. + INFO = 3 + RETURN + END IF +! + ! <6> Compute the eigenvectors (if requested) and, + ! the residuals (if requested). + ! + IF ( WNTVEC .OR. WNTEX ) THEN + IF ( WNTRES ) THEN + IF ( WNTREF ) THEN + ! Here, if the refinement is requested, we have + ! A*U(:,1:K) already computed and stored in Z. + ! For the residuals, need Y = A * U(:,1;K) * W. + CALL SGEMM( 'N', 'N', M, K, K, ONE, Z, LDZ, W, & + LDW, ZERO, Y, LDY ) ! BLAS CALL + ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC + ! This frees Z; Y contains A * U(:,1:K) * W. + ELSE + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL SGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & + W, LDW, ZERO, S, LDS ) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + LDS, ZERO, Z, LDZ ) + ! Save a copy of Z into Y and free Z for holding + ! the Ritz vectors. + CALL SLACPY( 'A', M, K, Z, LDZ, Y, LDY ) + IF ( WNTEX ) CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF + ELSE IF ( WNTEX ) THEN + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL SGEMM( T_OR_N, 'N', N, K, K, ONE, Z, LDZ, & + W, LDW, ZERO, S, LDS ) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + LDS, ZERO, B, LDB ) + ! The above call replaces the following two calls + ! that were used in the developing-testing phase. + ! CALL SGEMM( 'N', 'N', M, K, N, ONE, Y, LDY, S, & + ! LDS, ZERO, Z, LDZ) + ! Save a copy of Z into B and free Z for holding + ! the Ritz vectors. + ! CALL SLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF +! + ! Compute the real form of the Ritz vectors + IF ( WNTVEC ) CALL SGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & + ZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC +! + IF ( WNTRES ) THEN + i = 1 + DO WHILE ( i <= K ) + IF ( IMEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL SAXPY( M, -REIG(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL + ! Y(1:M,i) = Y(1:M,i) - REIG(i) * Z(1:M,i) ! INTRINSIC + RES(i) = SNRM2( M, Y(1,i), 1 ) ! BLAS CALL + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IMEIG(i) + AB(1,2) = IMEIG(i) + AB(2,2) = REIG(i) + CALL SGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + LDZ, AB, 2, ONE, Y(1,i), LDY ) ! BLAS CALL + ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC + RES(i) = SLANGE( 'F', M, 2, Y(1,i), LDY, & + WORK(N+1) ) ! LAPACK CALL + RES(i+1) = RES(i) + i = i + 2 + END IF + END DO + END IF + END IF +! + IF ( WHTSVD == 4 ) THEN + WORK(N+1) = XSCL1 + WORK(N+2) = XSCL2 + END IF +! +! Successful exit. + IF ( .NOT. BADXY ) THEN + INFO = 0 + ELSE + ! A warning on possible data inconsistency. + ! This should be a rare event. + INFO = 4 + END IF +!............................................................ + RETURN +! ...... + END SUBROUTINE SGEDMD diff --git a/lapack-netlib/SRC/sgesvdx.f b/lapack-netlib/SRC/sgesvdx.f index 8b55b9b2e9..2f9ee92aea 100644 --- a/lapack-netlib/SRC/sgesvdx.f +++ b/lapack-netlib/SRC/sgesvdx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGESVDX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -260,6 +258,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -294,7 +293,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, REAL DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL SBDSVDX, SGEBRD, SGELQF, SGEQRF, SLACPY, + EXTERNAL SBDSVDX, SGEBRD, SGELQF, SGEQRF, + $ SLACPY, $ SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, $ SCOPY, XERBLA * .. @@ -302,7 +302,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANGE, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE, + $ SROUNDUP_LWORK * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT @@ -384,7 +385,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MAXWRK = 1 IF( MINMN.GT.0 ) THEN IF( M.GE.N ) THEN - MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( M.GE.MNTHR ) THEN * * Path 1 (M much larger than N) @@ -419,7 +421,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = MAX(N*(N*2+19),4*N+M) END IF ELSE - MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M) @@ -541,8 +544,10 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUP = ITAUQ + N ITEMP = ITAUP + N CALL SLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), N ) - CALL SGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), + $ N ) + CALL SGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), + $ WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * @@ -551,7 +556,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -563,7 +569,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), + $ LDU ) * * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -620,7 +627,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -632,7 +640,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), + $ LDU ) * * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -689,8 +698,10 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUP = ITAUQ + M ITEMP = ITAUP + M CALL SLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) - CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M ) - CALL SGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), + CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), + $ M ) + CALL SGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), + $ WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * @@ -699,7 +710,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -728,7 +740,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) + CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), + $ LDVT) * * Call SORMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) @@ -768,7 +781,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), + $ WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -797,7 +811,8 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) + CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), + $ LDVT) * * Call SORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) @@ -811,13 +826,14 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Undo scaling if necessary * - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, + IF( ISCL.EQ.1 .AND. NS.GT.0 ) THEN + IF( ANRM.GT.BIGNUM ) THEN + CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, NS, 1, $ S, MINMN, INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, + ELSE IF( ANRM.LT.SMLNUM ) THEN + CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, NS, 1, $ S, MINMN, INFO ) + ENDIF END IF * * Return optimal workspace in WORK(1) diff --git a/lapack-netlib/SRC/sgesvj.f b/lapack-netlib/SRC/sgesvj.f index 36aed2853c..25eec31df2 100644 --- a/lapack-netlib/SRC/sgesvj.f +++ b/lapack-netlib/SRC/sgesvj.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGESVJ + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -103,7 +101,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the input matrix A. 1/SLAMCH('E') > M >= 0. +*> The number of rows of the input matrix A. 1/SLAMCH('E') >= M >= 0. *> \endverbatim *> *> \param[in] N @@ -243,7 +241,7 @@ *> LWORK >= 1, if MIN(M,N) = 0, and LWORK >= MAX(6,M+N), otherwise. *> *> If on entry LWORK = -1, then a workspace query is assumed and -*> no computation is done; WORK(1) is set to the minial (and optimal) +*> no computation is done; WORK(1) is set to the minimal (and optimal) *> length of WORK. *> \endverbatim *> @@ -325,6 +323,7 @@ * ===================================================================== SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -352,7 +351,7 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, - $ THSIGN, TOL + $ THSIGN, TOL, TBIG INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, @@ -409,9 +408,13 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 - ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN + ELSE IF( .NOT.( LSVEC .OR. + $ UCTOL .OR. + $ LSAME( JOBU, 'N' ) ) ) THEN INFO = -2 - ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN + ELSE IF( .NOT.( RSVEC .OR. + $ APPLV .OR. + $ LSAME( JOBV, 'N' ) ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 @@ -424,8 +427,6 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN INFO = -11 - ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN - INFO = -12 ELSE IF( LWORK.LT.LWMIN .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 ELSE @@ -454,7 +455,12 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( UCTOL ) THEN * ... user controlled - CTOL = WORK( 1 ) + IF( WORK( 1 ).LE.ONE ) THEN + INFO = -12 + RETURN + ELSE + CTOL = WORK( 1 ) + ENDIF ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN @@ -521,7 +527,9 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT. TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -546,7 +554,9 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -571,7 +581,9 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -767,11 +779,13 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( UPPER ) THEN * * - CALL SGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV, + CALL SGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, + $ LDV, $ EPSLN, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N, $ IERR ) * - CALL SGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ), + CALL SGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, + $ WORK( N4+1 ), $ SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV, $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, $ IERR ) @@ -874,7 +888,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( SDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -889,7 +904,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( SDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -966,7 +982,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS - CALL SROTM( M, A( 1, p ), 1, + CALL SROTM( M, A( 1, p ), + $ 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL SROTM( MVL, @@ -982,7 +999,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS IF( RSVEC ) THEN - CALL SAXPY( MVL, -T*AQOAP, + CALL SAXPY( MVL, + $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL SAXPY( MVL, @@ -996,13 +1014,15 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL SAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) - CALL SAXPY( M, -CS*SN*AQOAP, + CALL SAXPY( M, + $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS IF( RSVEC ) THEN - CALL SAXPY( MVL, T*APOAQ, + CALL SAXPY( MVL, + $ T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL SAXPY( MVL, @@ -1016,7 +1036,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL SAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) - CALL SAXPY( M, CS*SN*APOAQ, + CALL SAXPY( M, + $ CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS @@ -1059,15 +1080,19 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. have to use modified Gram-Schmidt like transformation CALL SCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) - CALL SLASCL( 'G', 0, 0, AAPP, ONE, M, + CALL SLASCL( 'G', 0, 0, AAPP, ONE, + $ M, $ 1, WORK( N+1 ), LDA, $ IERR ) - CALL SLASCL( 'G', 0, 0, AAQQ, ONE, M, + CALL SLASCL( 'G', 0, 0, AAQQ, ONE, + $ M, $ 1, A( 1, q ), LDA, IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) - CALL SAXPY( M, TEMP1, WORK( N+1 ), 1, + CALL SAXPY( M, TEMP1, WORK( N+1 ), + $ 1, $ A( 1, q ), 1 ) - CALL SLASCL( 'G', 0, 0, ONE, AAQQ, M, + CALL SLASCL( 'G', 0, 0, ONE, AAQQ, + $ M, $ 1, A( 1, q ), LDA, IERR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) @@ -1082,7 +1107,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = SNRM2( M, A( 1, q ), 1 )* + SVA( q ) = SNRM2( M, A( 1, q ), + $ 1 )* $ WORK( q ) ELSE T = ZERO @@ -1181,7 +1207,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( SDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -1200,7 +1227,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, + AAPQ = ( SDOT( M, A( 1, p ), 1, + $ A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE @@ -1272,7 +1300,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS - CALL SROTM( M, A( 1, p ), 1, + CALL SROTM( M, A( 1, p ), + $ 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL SROTM( MVL, @@ -1286,7 +1315,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ A( 1, p ), 1, $ A( 1, q ), 1 ) IF( RSVEC ) THEN - CALL SAXPY( MVL, -T*AQOAP, + CALL SAXPY( MVL, + $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL SAXPY( MVL, @@ -1302,11 +1332,13 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL SAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) - CALL SAXPY( M, -CS*SN*AQOAP, + CALL SAXPY( M, + $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) IF( RSVEC ) THEN - CALL SAXPY( MVL, T*APOAQ, + CALL SAXPY( MVL, + $ T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL SAXPY( MVL, @@ -1322,7 +1354,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL SAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) - CALL SAXPY( M, CS*SN*APOAQ, + CALL SAXPY( M, + $ CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS @@ -1365,16 +1398,20 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAPP.GT.AAQQ ) THEN CALL SCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) - CALL SLASCL( 'G', 0, 0, AAPP, ONE, + CALL SLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) - CALL SLASCL( 'G', 0, 0, AAQQ, ONE, + CALL SLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) - CALL SAXPY( M, TEMP1, WORK( N+1 ), + CALL SAXPY( M, TEMP1, + $ WORK( N+1 ), $ 1, A( 1, q ), 1 ) - CALL SLASCL( 'G', 0, 0, ONE, AAQQ, + CALL SLASCL( 'G', 0, 0, ONE, + $ AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, @@ -1383,16 +1420,20 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE CALL SCOPY( M, A( 1, q ), 1, $ WORK( N+1 ), 1 ) - CALL SLASCL( 'G', 0, 0, AAQQ, ONE, + CALL SLASCL( 'G', 0, 0, AAQQ, + $ ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) - CALL SLASCL( 'G', 0, 0, AAPP, ONE, + CALL SLASCL( 'G', 0, 0, AAPP, + $ ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( q ) / WORK( p ) - CALL SAXPY( M, TEMP1, WORK( N+1 ), + CALL SAXPY( M, TEMP1, + $ WORK( N+1 ), $ 1, A( 1, p ), 1 ) - CALL SLASCL( 'G', 0, 0, ONE, AAPP, + CALL SLASCL( 'G', 0, 0, ONE, + $ AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*SQRT( MAX( ZERO, @@ -1408,7 +1449,8 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN - SVA( q ) = SNRM2( M, A( 1, q ), 1 )* + SVA( q ) = SNRM2( M, A( 1, q ), + $ 1 )* $ WORK( q ) ELSE T = ZERO @@ -1554,7 +1596,9 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( LSVEC .OR. UCTOL ) THEN DO 1998 p = 1, N2 - CALL SSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 ) + TEMP1 = ONE + IF( SVA(p).GT.ZERO ) TEMP1 = ONE/SVA(p) + CALL SSCAL( M, WORK( p )*TEMP1, A( 1, p ), 1 ) 1998 CONTINUE END IF * @@ -1574,9 +1618,14 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) - $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. - $ ( SFMIN / SKL ) ) ) ) THEN + NOSCALE = .FALSE. + IF ( SKL.GT.ONE ) THEN + IF( SVA( 1 ).LT.( BIG / SKL ) ) NOSCALE = .TRUE. + ELSE IF( SKL.LT.ONE ) THEN + IF ( SVA( MAX( N2, 1 ) ) .GT. + $ ( SFMIN / SKL ) ) NOSCALE = .TRUE. + ENDIF + IF( NOSCALE ) THEN DO 2400 p = 1, N SVA( P ) = SKL*SVA( P ) 2400 CONTINUE diff --git a/lapack-netlib/SRC/zgedmd.f90 b/lapack-netlib/SRC/zgedmd.f90 index 5045cb166c..53f41a9c97 100644 --- a/lapack-netlib/SRC/zgedmd.f90 +++ b/lapack-netlib/SRC/zgedmd.f90 @@ -1,1148 +1,1154 @@ -!> \brief \b ZGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. -! -! =========== DOCUMENTATION =========== -! -! Definition: -! =========== -! -! SUBROUTINE ZGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & -! M, N, X, LDX, Y, LDY, NRNK, TOL, & -! K, EIGS, Z, LDZ, RES, B, LDB, & -! W, LDW, S, LDS, ZWORK, LZWORK, & -! RWORK, LRWORK, IWORK, LIWORK, INFO ) -!...... -! USE iso_fortran_env -! IMPLICIT NONE -! INTEGER, PARAMETER :: WP = real64 -! -!...... -! Scalar arguments -! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF -! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & -! NRNK, LDZ, LDB, LDW, LDS, & -! LIWORK, LRWORK, LZWORK -! INTEGER, INTENT(OUT) :: K, INFO -! REAL(KIND=WP), INTENT(IN) :: TOL -! Array arguments -! COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) -! COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & -! W(LDW,*), S(LDS,*) -! COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) -! COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) -! REAL(KIND=WP), INTENT(OUT) :: RES(*) -! REAL(KIND=WP), INTENT(OUT) :: RWORK(*) -! INTEGER, INTENT(OUT) :: IWORK(*) -! -!............................................................ -!> \par Purpose: -! ============= -!> \verbatim -!> ZGEDMD computes the Dynamic Mode Decomposition (DMD) for -!> a pair of data snapshot matrices. For the input matrices -!> X and Y such that Y = A*X with an unaccessible matrix -!> A, ZGEDMD computes a certain number of Ritz pairs of A using -!> the standard Rayleigh-Ritz extraction from a subspace of -!> range(X) that is determined using the leading left singular -!> vectors of X. Optionally, ZGEDMD returns the residuals -!> of the computed Ritz pairs, the information needed for -!> a refinement of the Ritz vectors, or the eigenvectors of -!> the Exact DMD. -!> For further details see the references listed -!> below. For more details of the implementation see [3]. -!> \endverbatim -!............................................................ -!> \par References: -! ================ -!> \verbatim -!> [1] P. Schmid: Dynamic mode decomposition of numerical -!> and experimental data, -!> Journal of Fluid Mechanics 656, 5-28, 2010. -!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal -!> decompositions: analysis and enhancements, -!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. -!> [3] Z. Drmac: A LAPACK implementation of the Dynamic -!> Mode Decomposition I. Technical report. AIMDyn Inc. -!> and LAPACK Working Note 298. -!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. -!> Brunton, N. Kutz: On Dynamic Mode Decomposition: -!> Theory and Applications, Journal of Computational -!> Dynamics 1(2), 391 -421, 2014. -!> \endverbatim -!...................................................................... -!> \par Developed and supported by: -! ================================ -!> \verbatim -!> Developed and coded by Zlatko Drmac, Faculty of Science, -!> University of Zagreb; drmac@math.hr -!> In cooperation with -!> AIMdyn Inc., Santa Barbara, CA. -!> and supported by -!> - DARPA SBIR project "Koopman Operator-Based Forecasting -!> for Nonstationary Processes from Near-Term, Limited -!> Observational Data" Contract No: W31P4Q-21-C-0007 -!> - DARPA PAI project "Physics-Informed Machine Learning -!> Methodologies" Contract No: HR0011-18-9-0033 -!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic -!> Framework for Space-Time Analysis of Process Dynamics" -!> Contract No: HR0011-16-C-0116 -!> Any opinions, findings and conclusions or recommendations -!> expressed in this material are those of the author and -!> do not necessarily reflect the views of the DARPA SBIR -!> Program Office -!> \endverbatim -!...................................................................... -!> \par Distribution Statement A: -! ============================== -!> \verbatim -!> Approved for Public Release, Distribution Unlimited. -!> Cleared by DARPA on September 29, 2022 -!> \endverbatim -!............................................................ -! Arguments -! ========= -! -!> \param[in] JOBS -!> \verbatim -!> JOBS (input) CHARACTER*1 -!> Determines whether the initial data snapshots are scaled -!> by a diagonal matrix. -!> 'S' :: The data snapshots matrices X and Y are multiplied -!> with a diagonal matrix D so that X*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'C' :: The snapshots are scaled as with the 'S' option. -!> If it is found that an i-th column of X is zero -!> vector and the corresponding i-th column of Y is -!> non-zero, then the i-th column of Y is set to -!> zero and a warning flag is raised. -!> 'Y' :: The data snapshots matrices X and Y are multiplied -!> by a diagonal matrix D so that Y*D has unit -!> nonzero columns (in the Euclidean 2-norm) -!> 'N' :: No data scaling. -!> \endverbatim -!..... -!> \param[in] JOBZ -!> \verbatim -!> JOBZ (input) CHARACTER*1 -!> Determines whether the eigenvectors (Koopman modes) will -!> be computed. -!> 'V' :: The eigenvectors (Koopman modes) will be computed -!> and returned in the matrix Z. -!> See the description of Z. -!> 'F' :: The eigenvectors (Koopman modes) will be returned -!> in factored form as the product X(:,1:K)*W, where X -!> contains a POD basis (leading left singular vectors -!> of the data matrix X) and W contains the eigenvectors -!> of the corresponding Rayleigh quotient. -!> See the descriptions of K, X, W, Z. -!> 'N' :: The eigenvectors are not computed. -!> \endverbatim -!..... -!> \param[in] JOBR -!> \verbatim -!> JOBR (input) CHARACTER*1 -!> Determines whether to compute the residuals. -!> 'R' :: The residuals for the computed eigenpairs will be -!> computed and stored in the array RES. -!> See the description of RES. -!> For this option to be legal, JOBZ must be 'V'. -!> 'N' :: The residuals are not computed. -!> \endverbatim -!..... -!> \param[in] JOBF -!> \verbatim -!> JOBF (input) CHARACTER*1 -!> Specifies whether to store information needed for post- -!> processing (e.g. computing refined Ritz vectors) -!> 'R' :: The matrix needed for the refinement of the Ritz -!> vectors is computed and stored in the array B. -!> See the description of B. -!> 'E' :: The unscaled eigenvectors of the Exact DMD are -!> computed and returned in the array B. See the -!> description of B. -!> 'N' :: No eigenvector refinement data is computed. -!> \endverbatim -!..... -!> \param[in] WHTSVD -!> \verbatim -!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } -!> Allows for a selection of the SVD algorithm from the -!> LAPACK library. -!> 1 :: ZGESVD (the QR SVD algorithm) -!> 2 :: ZGESDD (the Divide and Conquer algorithm; if enough -!> workspace available, this is the fastest option) -!> 3 :: ZGESVDQ (the preconditioned QR SVD ; this and 4 -!> are the most accurate options) -!> 4 :: ZGEJSV (the preconditioned Jacobi SVD; this and 3 -!> are the most accurate options) -!> For the four methods above, a significant difference in -!> the accuracy of small singular values is possible if -!> the snapshots vary in norm so that X is severely -!> ill-conditioned. If small (smaller than EPS*||X||) -!> singular values are of interest and JOBS=='N', then -!> the options (3, 4) give the most accurate results, where -!> the option 4 is slightly better and with stronger -!> theoretical background. -!> If JOBS=='S', i.e. the columns of X will be normalized, -!> then all methods give nearly equally accurate results. -!> \endverbatim -!..... -!> \param[in] M -!> \verbatim -!> M (input) INTEGER, M>= 0 -!> The state space dimension (the row dimension of X, Y). -!> \endverbatim -!..... -!> \param[in] N -!> \verbatim -!> N (input) INTEGER, 0 <= N <= M -!> The number of data snapshot pairs -!> (the number of columns of X and Y). -!> \endverbatim -!..... -!> \param[in] LDX -!> \verbatim -!> X (input/output) COMPLEX(KIND=WP) M-by-N array -!> > On entry, X contains the data snapshot matrix X. It is -!> assumed that the column norms of X are in the range of -!> the normalized floating point numbers. -!> < On exit, the leading K columns of X contain a POD basis, -!> i.e. the leading K left singular vectors of the input -!> data matrix X, U(:,1:K). All N columns of X contain all -!> left singular vectors of the input matrix X. -!> See the descriptions of K, Z and W. -!..... -!> LDX (input) INTEGER, LDX >= M -!> The leading dimension of the array X. -!> \endverbatim -!..... -!> \param[in,out] Y -!> \verbatim -!> Y (input/workspace/output) COMPLEX(KIND=WP) M-by-N array -!> > On entry, Y contains the data snapshot matrix Y -!> < On exit, -!> If JOBR == 'R', the leading K columns of Y contain -!> the residual vectors for the computed Ritz pairs. -!> See the description of RES. -!> If JOBR == 'N', Y contains the original input data, -!> scaled according to the value of JOBS. -!> \endverbatim -!..... -!> \param[in] LDY -!> \verbatim -!> LDY (input) INTEGER , LDY >= M -!> The leading dimension of the array Y. -!> \endverbatim -!..... -!> \param[in] NRNK -!> \verbatim -!> NRNK (input) INTEGER -!> Determines the mode how to compute the numerical rank, -!> i.e. how to truncate small singular values of the input -!> matrix X. On input, if -!> NRNK = -1 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(1) -!> This option is recommended. -!> NRNK = -2 :: i-th singular value sigma(i) is truncated -!> if sigma(i) <= TOL*sigma(i-1) -!> This option is included for R&D purposes. -!> It requires highly accurate SVD, which -!> may not be feasible. -!> The numerical rank can be enforced by using positive -!> value of NRNK as follows: -!> 0 < NRNK <= N :: at most NRNK largest singular values -!> will be used. If the number of the computed nonzero -!> singular values is less than NRNK, then only those -!> nonzero values will be used and the actually used -!> dimension is less than NRNK. The actual number of -!> the nonzero singular values is returned in the variable -!> K. See the descriptions of TOL and K. -!> \endverbatim -!..... -!> \param[in] TOL -!> \verbatim -!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 -!> The tolerance for truncating small singular values. -!> See the description of NRNK. -!> \endverbatim -!..... -!> \param[out] K -!> \verbatim -!> K (output) INTEGER, 0 <= K <= N -!> The dimension of the POD basis for the data snapshot -!> matrix X and the number of the computed Ritz pairs. -!> The value of K is determined according to the rule set -!> by the parameters NRNK and TOL. -!> See the descriptions of NRNK and TOL. -!> \endverbatim -!..... -!> \param[out] EIGS -!> \verbatim -!> EIGS (output) COMPLEX(KIND=WP) N-by-1 array -!> The leading K (K<=N) entries of EIGS contain -!> the computed eigenvalues (Ritz values). -!> See the descriptions of K, and Z. -!> \endverbatim -!..... -!> \param[out] Z -!> \verbatim -!> Z (workspace/output) COMPLEX(KIND=WP) M-by-N array -!> If JOBZ =='V' then Z contains the Ritz vectors. Z(:,i) -!> is an eigenvector of the i-th Ritz value; ||Z(:,i)||_2=1. -!> If JOBZ == 'F', then the Z(:,i)'s are given implicitly as -!> the columns of X(:,1:K)*W(1:K,1:K), i.e. X(:,1:K)*W(:,i) -!> is an eigenvector corresponding to EIGS(i). The columns -!> of W(1:k,1:K) are the computed eigenvectors of the -!> K-by-K Rayleigh quotient. -!> See the descriptions of EIGS, X and W. -!> \endverbatim -!..... -!> \param[in] LDZ -!> \verbatim -!> LDZ (input) INTEGER , LDZ >= M -!> The leading dimension of the array Z. -!> \endverbatim -!..... -!> \param[out] RES -!> \verbatim -!> RES (output) REAL(KIND=WP) N-by-1 array -!> RES(1:K) contains the residuals for the K computed -!> Ritz pairs, -!> RES(i) = || A * Z(:,i) - EIGS(i)*Z(:,i))||_2. -!> See the description of EIGS and Z. -!> \endverbatim -!..... -!> \param[out] B -!> \verbatim -!> B (output) COMPLEX(KIND=WP) M-by-N array. -!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can -!> be used for computing the refined vectors; see further -!> details in the provided references. -!> If JOBF == 'E', B(1:M,1:K) contains -!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the -!> Exact DMD, up to scaling by the inverse eigenvalues. -!> If JOBF =='N', then B is not referenced. -!> See the descriptions of X, W, K. -!> \endverbatim -!..... -!> \param[in] LDB -!> \verbatim -!> LDB (input) INTEGER, LDB >= M -!> The leading dimension of the array B. -!> \endverbatim -!..... -!> \param[out] W -!> \verbatim -!> W (workspace/output) COMPLEX(KIND=WP) N-by-N array -!> On exit, W(1:K,1:K) contains the K computed -!> eigenvectors of the matrix Rayleigh quotient. -!> The Ritz vectors (returned in Z) are the -!> product of X (containing a POD basis for the input -!> matrix X) and W. See the descriptions of K, S, X and Z. -!> W is also used as a workspace to temporarily store the -!> right singular vectors of X. -!> \endverbatim -!..... -!> \param[in] LDW -!> \verbatim -!> LDW (input) INTEGER, LDW >= N -!> The leading dimension of the array W. -!> \endverbatim -!..... -!> \param[out] S -!> \verbatim -!> S (workspace/output) COMPLEX(KIND=WP) N-by-N array -!> The array S(1:K,1:K) is used for the matrix Rayleigh -!> quotient. This content is overwritten during -!> the eigenvalue decomposition by ZGEEV. -!> See the description of K. -!> \endverbatim -!..... -!> \param[in] LDS -!> \verbatim -!> LDS (input) INTEGER, LDS >= N -!> The leading dimension of the array S. -!> \endverbatim -!..... -!> \param[out] ZWORK -!> \verbatim -!> ZWORK (workspace/output) COMPLEX(KIND=WP) LZWORK-by-1 array -!> ZWORK is used as complex workspace in the complex SVD, as -!> specified by WHTSVD (1,2, 3 or 4) and for ZGEEV for computing -!> the eigenvalues of a Rayleigh quotient. -!> If the call to ZGEDMD is only workspace query, then -!> ZWORK(1) contains the minimal complex workspace length and -!> ZWORK(2) is the optimal complex workspace length. -!> Hence, the length of work is at least 2. -!> See the description of LZWORK. -!> \endverbatim -!..... -!> \param[in] LZWORK -!> \verbatim -!> LZWORK (input) INTEGER -!> The minimal length of the workspace vector ZWORK. -!> LZWORK is calculated as MAX(LZWORK_SVD, LZWORK_ZGEEV), -!> where LZWORK_ZGEEV = MAX( 1, 2*N ) and the minimal -!> LZWORK_SVD is calculated as follows -!> If WHTSVD == 1 :: ZGESVD :: -!> LZWORK_SVD = MAX(1,2*MIN(M,N)+MAX(M,N)) -!> If WHTSVD == 2 :: ZGESDD :: -!> LZWORK_SVD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) -!> If WHTSVD == 3 :: ZGESVDQ :: -!> LZWORK_SVD = obtainable by a query -!> If WHTSVD == 4 :: ZGEJSV :: -!> LZWORK_SVD = obtainable by a query -!> If on entry LZWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths and returns them in -!> LZWORK(1) and LZWORK(2), respectively. -!> \endverbatim -!..... -!> \param[out] RWORK -!> \verbatim -!> RWORK (workspace/output) REAL(KIND=WP) LRWORK-by-1 array -!> On exit, RWORK(1:N) contains the singular values of -!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). -!> If WHTSVD==4, then RWORK(N+1) and RWORK(N+2) contain -!> scaling factor RWORK(N+2)/RWORK(N+1) used to scale X -!> and Y to avoid overflow in the SVD of X. -!> This may be of interest if the scaling option is off -!> and as many as possible smallest eigenvalues are -!> desired to the highest feasible accuracy. -!> If the call to ZGEDMD is only workspace query, then -!> RWORK(1) contains the minimal workspace length. -!> See the description of LRWORK. -!> \endverbatim -!..... -!> \param[in] LRWORK -!> \verbatim -!> LRWORK (input) INTEGER -!> The minimal length of the workspace vector RWORK. -!> LRWORK is calculated as follows: -!> LRWORK = MAX(1, N+LRWORK_SVD,N+LRWORK_ZGEEV), where -!> LRWORK_ZGEEV = MAX(1,2*N) and RWORK_SVD is the real workspace -!> for the SVD subroutine determined by the input parameter -!> WHTSVD. -!> If WHTSVD == 1 :: ZGESVD :: -!> LRWORK_SVD = 5*MIN(M,N) -!> If WHTSVD == 2 :: ZGESDD :: -!> LRWORK_SVD = MAX(5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), -!> 2*MAX(M,N)*MIN(M,N)+2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) -!> If WHTSVD == 3 :: ZGESVDQ :: -!> LRWORK_SVD = obtainable by a query -!> If WHTSVD == 4 :: ZGEJSV :: -!> LRWORK_SVD = obtainable by a query -!> If on entry LRWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> real workspace length and returns it in RWORK(1). -!> \endverbatim -!..... -!> \param[out] IWORK -!> \verbatim -!> IWORK (workspace/output) INTEGER LIWORK-by-1 array -!> Workspace that is required only if WHTSVD equals -!> 2 , 3 or 4. (See the description of WHTSVD). -!> If on entry LWORK =-1 or LIWORK=-1, then the -!> minimal length of IWORK is computed and returned in -!> IWORK(1). See the description of LIWORK. -!> \endverbatim -!..... -!> \param[in] LIWORK -!> \verbatim -!> LIWORK (input) INTEGER -!> The minimal length of the workspace vector IWORK. -!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 -!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) -!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) -!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) -!> If on entry LIWORK = -1, then a workspace query is -!> assumed and the procedure only computes the minimal -!> and the optimal workspace lengths for ZWORK, RWORK and -!> IWORK. See the descriptions of ZWORK, RWORK and IWORK. -!> \endverbatim -!..... -!> \param[out] INFO -!> \verbatim -!> INFO (output) INTEGER -!> -i < 0 :: On entry, the i-th argument had an -!> illegal value -!> = 0 :: Successful return. -!> = 1 :: Void input. Quick exit (M=0 or N=0). -!> = 2 :: The SVD computation of X did not converge. -!> Suggestion: Check the input data and/or -!> repeat with different WHTSVD. -!> = 3 :: The computation of the eigenvalues did not -!> converge. -!> = 4 :: If data scaling was requested on input and -!> the procedure found inconsistency in the data -!> such that for some column index i, -!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set -!> to zero if JOBS=='C'. The computation proceeds -!> with original or modified data and warning -!> flag is set with INFO=4. -!> \endverbatim -! -! Authors: -! ======== -! -!> \author Zlatko Drmac -! -!> \ingroup gedmd -! -!............................................................. -!............................................................. - SUBROUTINE ZGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & - M, N, X, LDX, Y, LDY, NRNK, TOL, & - K, EIGS, Z, LDZ, RES, B, LDB, & - W, LDW, S, LDS, ZWORK, LZWORK, & - RWORK, LRWORK, IWORK, LIWORK, INFO ) -! -! -- LAPACK driver routine -- -! -! -- LAPACK is a software package provided by University of -- -! -- Tennessee, University of California Berkeley, University of -- -! -- Colorado Denver and NAG Ltd.. -- -! -!..... - USE iso_fortran_env - IMPLICIT NONE - INTEGER, PARAMETER :: WP = real64 -! -! Scalar arguments -! ~~~~~~~~~~~~~~~~ - CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF - INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & - NRNK, LDZ, LDB, LDW, LDS, & - LIWORK, LRWORK, LZWORK - INTEGER, INTENT(OUT) :: K, INFO - REAL(KIND=WP), INTENT(IN) :: TOL -! -! Array arguments -! ~~~~~~~~~~~~~~~ - COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) - COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & - W(LDW,*), S(LDS,*) - COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) - COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) - REAL(KIND=WP), INTENT(OUT) :: RES(*) - REAL(KIND=WP), INTENT(OUT) :: RWORK(*) - INTEGER, INTENT(OUT) :: IWORK(*) -! -! Parameters -! ~~~~~~~~~~ - REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP - REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP - COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP ) - COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP ) -! -! Local scalars -! ~~~~~~~~~~~~~ - REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & - SSUM, XSCL1, XSCL2 - INTEGER :: i, j, IMINWR, INFO1, INFO2, & - LWRKEV, LWRSDD, LWRSVD, LWRSVJ, & - LWRSVQ, MLWORK, MWRKEV, MWRSDD, & - MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & - OLWORK, MLRWRK - LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & - WNTEX, WNTREF, WNTRES, WNTVEC - CHARACTER :: JOBZL, T_OR_N - CHARACTER :: JSVOPT -! -! Local arrays -! ~~~~~~~~~~~~ - REAL(KIND=WP) :: RDUMMY(2) -! -! External functions (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~ - REAL(KIND=WP) ZLANGE, DLAMCH, DZNRM2 - EXTERNAL ZLANGE, DLAMCH, DZNRM2, IZAMAX - INTEGER IZAMAX - LOGICAL DISNAN, LSAME - EXTERNAL DISNAN, LSAME -! -! External subroutines (BLAS and LAPACK) -! ~~~~~~~~~~~~~~~~~~~~ - EXTERNAL ZAXPY, ZGEMM, ZDSCAL - EXTERNAL ZGEEV, ZGEJSV, ZGESDD, ZGESVD, ZGESVDQ, & - ZLACPY, ZLASCL, ZLASSQ, XERBLA -! -! Intrinsic functions -! ~~~~~~~~~~~~~~~~~~~ - INTRINSIC DBLE, INT, MAX, SQRT -!............................................................ -! -! Test the input arguments -! - WNTRES = LSAME(JOBR,'R') - SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') - SCCOLY = LSAME(JOBS,'Y') - WNTVEC = LSAME(JOBZ,'V') - WNTREF = LSAME(JOBF,'R') - WNTEX = LSAME(JOBF,'E') - INFO = 0 - LQUERY = ( ( LZWORK == -1 ) .OR. ( LIWORK == -1 ) & - .OR. ( LRWORK == -1 ) ) -! - IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & - LSAME(JOBS,'N')) ) THEN - INFO = -1 - ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & - .OR. LSAME(JOBZ,'F')) ) THEN - INFO = -2 - ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & - ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN - INFO = -3 - ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & - LSAME(JOBF,'N') ) ) THEN - INFO = -4 - ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & - (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN - INFO = -5 - ELSE IF ( M < 0 ) THEN - INFO = -6 - ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN - INFO = -7 - ELSE IF ( LDX < M ) THEN - INFO = -9 - ELSE IF ( LDY < M ) THEN - INFO = -11 - ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & - ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN - INFO = -12 - ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN - INFO = -13 - ELSE IF ( LDZ < M ) THEN - INFO = -17 - ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN - INFO = -20 - ELSE IF ( LDW < N ) THEN - INFO = -22 - ELSE IF ( LDS < N ) THEN - INFO = -24 - END IF -! - IF ( INFO == 0 ) THEN - ! Compute the minimal and the optimal workspace - ! requirements. Simulate running the code and - ! determine minimal and optimal sizes of the - ! workspace at any moment of the run. - IF ( N == 0 ) THEN - ! Quick return. All output except K is void. - ! INFO=1 signals the void input. - ! In case of a workspace query, the default - ! minimal workspace lengths are returned. - IF ( LQUERY ) THEN - IWORK(1) = 1 - RWORK(1) = 1 - ZWORK(1) = 2 - ZWORK(2) = 2 - ELSE - K = 0 - END IF - INFO = 1 - RETURN - END IF - - IMINWR = 1 - MLRWRK = MAX(1,N) - MLWORK = 2 - OLWORK = 2 - SELECT CASE ( WHTSVD ) - CASE (1) - ! The following is specified as the minimal - ! length of WORK in the definition of ZGESVD: - ! MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) - MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) - MLWORK = MAX(MLWORK,MWRSVD) - MLRWRK = MAX(MLRWRK,N + 5*MIN(M,N)) - IF ( LQUERY ) THEN - CALL ZGESVD( 'O', 'S', M, N, X, LDX, RWORK, & - B, LDB, W, LDW, ZWORK, -1, RDUMMY, INFO1 ) - LWRSVD = INT( ZWORK(1) ) - OLWORK = MAX(OLWORK,LWRSVD) - END IF - CASE (2) - ! The following is specified as the minimal - ! length of WORK in the definition of ZGESDD: - ! MWRSDD = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). - ! RWORK length: 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N) - ! In LAPACK 3.10.1 RWORK is defined differently. - ! Below we take max over the two versions. - ! IMINWR = 8*MIN(M,N) - MWRSDD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) - MLWORK = MAX(MLWORK,MWRSDD) - IMINWR = 8*MIN(M,N) - MLRWRK = MAX( MLRWRK, N + & - MAX( 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), & - 5*MIN(M,N)*MIN(M,N)+5*MIN(M,N), & - 2*MAX(M,N)*MIN(M,N)+ & - 2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) - IF ( LQUERY ) THEN - CALL ZGESDD( 'O', M, N, X, LDX, RWORK, B,LDB,& - W, LDW, ZWORK, -1, RDUMMY, IWORK, INFO1 ) - LWRSDD = MAX( MWRSDD,INT( ZWORK(1) )) - ! Possible bug in ZGESDD optimal workspace size. - OLWORK = MAX(OLWORK,LWRSDD) - END IF - CASE (3) - CALL ZGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, RWORK, Z, LDZ, W, LDW, NUMRNK, & - IWORK, -1, ZWORK, -1, RDUMMY, -1, INFO1 ) - IMINWR = IWORK(1) - MWRSVQ = INT(ZWORK(2)) - MLWORK = MAX(MLWORK,MWRSVQ) - MLRWRK = MAX(MLRWRK,N + INT(RDUMMY(1))) - IF ( LQUERY ) THEN - LWRSVQ = INT(ZWORK(1)) - OLWORK = MAX(OLWORK,LWRSVQ) - END IF - CASE (4) - JSVOPT = 'J' - CALL ZGEJSV( 'F', 'U', JSVOPT, 'R', 'N', 'P', M, & - N, X, LDX, RWORK, Z, LDZ, W, LDW, & - ZWORK, -1, RDUMMY, -1, IWORK, INFO1 ) - IMINWR = IWORK(1) - MWRSVJ = INT(ZWORK(2)) - MLWORK = MAX(MLWORK,MWRSVJ) - MLRWRK = MAX(MLRWRK,N + MAX(7,INT(RDUMMY(1)))) - IF ( LQUERY ) THEN - LWRSVJ = INT(ZWORK(1)) - OLWORK = MAX(OLWORK,LWRSVJ) - END IF - END SELECT - IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN - JOBZL = 'V' - ELSE - JOBZL = 'N' - END IF - ! Workspace calculation to the ZGEEV call - MWRKEV = MAX( 1, 2*N ) - MLWORK = MAX(MLWORK,MWRKEV) - MLRWRK = MAX(MLRWRK,N+2*N) - IF ( LQUERY ) THEN - CALL ZGEEV( 'N', JOBZL, N, S, LDS, EIGS, & - W, LDW, W, LDW, ZWORK, -1, RWORK, INFO1 ) - LWRKEV = INT(ZWORK(1)) - OLWORK = MAX( OLWORK, LWRKEV ) - END IF -! - IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -30 - IF ( LRWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -28 - IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -26 - - END IF -! - IF( INFO /= 0 ) THEN - CALL XERBLA( 'ZGEDMD', -INFO ) - RETURN - ELSE IF ( LQUERY ) THEN -! Return minimal and optimal workspace sizes - IWORK(1) = IMINWR - RWORK(1) = MLRWRK - ZWORK(1) = MLWORK - ZWORK(2) = OLWORK - RETURN - END IF -!............................................................ -! - OFL = DLAMCH('O') - SMALL = DLAMCH('S') - BADXY = .FALSE. -! -! <1> Optional scaling of the snapshots (columns of X, Y) -! ========================================================== - IF ( SCCOLX ) THEN - ! The columns of X will be normalized. - ! To prevent overflows, the column norms of X are - ! carefully computed using ZLASSQ. - K = 0 - DO i = 1, N - !WORK(i) = DZNRM2( M, X(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL ZLASSQ( M, X(1,i), 1, SCALE, SSUM ) - IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN - K = 0 - INFO = -8 - CALL XERBLA('ZGEDMD',-INFO) - END IF - IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of X(:,i) overflows. First, X(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. -! Next, the norm of X(:,i) is stored without -! overflow as RWORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of X(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL ZLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, X(1,i), LDX, INFO2 ) - RWORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) - ELSE -! X(:,i) will be scaled to unit 2-norm - RWORK(i) = SCALE * ROOTSC - CALL ZLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & - X(1,i), LDX, INFO2 ) ! LAPACK CALL -! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC - END IF - ELSE - RWORK(i) = ZERO - K = K + 1 - END IF - END DO - IF ( K == N ) THEN - ! All columns of X are zero. Return error code -8. - ! (the 8th input variable had an illegal value) - K = 0 - INFO = -8 - CALL XERBLA('ZGEDMD',-INFO) - RETURN - END IF - DO i = 1, N -! Now, apply the same scaling to the columns of Y. - IF ( RWORK(i) > ZERO ) THEN - CALL ZDSCAL( M, ONE/RWORK(i), Y(1,i), 1 ) ! BLAS CALL -! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC - ELSE IF ( RWORK(i) < ZERO ) THEN - CALL ZLASCL( 'G', 0, 0, -RWORK(i), & - ONE/DBLE(M), M, 1, Y(1,i), LDY, INFO2 ) ! LAPACK CALL - ELSE IF ( ABS(Y(IZAMAX(M, Y(1,i),1),i )) & - /= ZERO ) THEN -! X(:,i) is zero vector. For consistency, -! Y(:,i) should also be zero. If Y(:,i) is not -! zero, then the data might be inconsistent or -! corrupted. If JOBS == 'C', Y(:,i) is set to -! zero and a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - IF ( LSAME(JOBS,'C')) & - CALL ZDSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL - END IF - END DO - END IF - ! - IF ( SCCOLY ) THEN - ! The columns of Y will be normalized. - ! To prevent overflows, the column norms of Y are - ! carefully computed using ZLASSQ. - DO i = 1, N - !RWORK(i) = DZNRM2( M, Y(1,i), 1 ) - SSUM = ONE - SCALE = ZERO - CALL ZLASSQ( M, Y(1,i), 1, SCALE, SSUM ) - IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN - K = 0 - INFO = -10 - CALL XERBLA('ZGEDMD',-INFO) - END IF - IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN - ROOTSC = SQRT(SSUM) - IF ( SCALE .GE. (OFL / ROOTSC) ) THEN -! Norm of Y(:,i) overflows. First, Y(:,i) -! is scaled by -! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. -! Next, the norm of Y(:,i) is stored without -! overflow as RWORK(i) = - SCALE * (ROOTSC/M), -! the minus sign indicating the 1/M factor. -! Scaling is performed without overflow, and -! underflow may occur in the smallest entries -! of Y(:,i). The relative backward and forward -! errors are small in the ell_2 norm. - CALL ZLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & - M, 1, Y(1,i), LDY, INFO2 ) - RWORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) - ELSE -! Y(:,i) will be scaled to unit 2-norm - RWORK(i) = SCALE * ROOTSC - CALL ZLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & - Y(1,i), LDY, INFO2 ) ! LAPACK CALL -! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC - END IF - ELSE - RWORK(i) = ZERO - END IF - END DO - DO i = 1, N -! Now, apply the same scaling to the columns of X. - IF ( RWORK(i) > ZERO ) THEN - CALL ZDSCAL( M, ONE/RWORK(i), X(1,i), 1 ) ! BLAS CALL -! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC - ELSE IF ( RWORK(i) < ZERO ) THEN - CALL ZLASCL( 'G', 0, 0, -RWORK(i), & - ONE/DBLE(M), M, 1, X(1,i), LDX, INFO2 ) ! LAPACK CALL - ELSE IF ( ABS(X(IZAMAX(M, X(1,i),1),i )) & - /= ZERO ) THEN -! Y(:,i) is zero vector. If X(:,i) is not -! zero, then a warning flag is raised. -! The computation continues but the -! situation will be reported in the output. - BADXY = .TRUE. - END IF - END DO - END IF -! -! <2> SVD of the data snapshot matrix X. -! ===================================== -! The left singular vectors are stored in the array X. -! The right singular vectors are in the array W. -! The array W will later on contain the eigenvectors -! of a Rayleigh quotient. - NUMRNK = N - SELECT CASE ( WHTSVD ) - CASE (1) - CALL ZGESVD( 'O', 'S', M, N, X, LDX, RWORK, B, & - LDB, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL - T_OR_N = 'C' - CASE (2) - CALL ZGESDD( 'O', M, N, X, LDX, RWORK, B, LDB, W, & - LDW, ZWORK, LZWORK, RWORK(N+1), IWORK, INFO1 ) ! LAPACK CALL - T_OR_N = 'C' - CASE (3) - CALL ZGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & - X, LDX, RWORK, Z, LDZ, W, LDW, & - NUMRNK, IWORK, LIWORK, ZWORK, & - LZWORK, RWORK(N+1), LRWORK-N, INFO1) ! LAPACK CALL - CALL ZLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'C' - CASE (4) - CALL ZGEJSV( 'F', 'U', JSVOPT, 'R', 'N', 'P', M, & - N, X, LDX, RWORK, Z, LDZ, W, LDW, & - ZWORK, LZWORK, RWORK(N+1), LRWORK-N, IWORK, INFO1 ) ! LAPACK CALL - CALL ZLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL - T_OR_N = 'N' - XSCL1 = RWORK(N+1) - XSCL2 = RWORK(N+2) - IF ( XSCL1 /= XSCL2 ) THEN - ! This is an exceptional situation. If the - ! data matrices are not scaled and the - ! largest singular value of X overflows. - ! In that case ZGEJSV can return the SVD - ! in scaled form. The scaling factor can be used - ! to rescale the data (X and Y). - CALL ZLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) - END IF - END SELECT -! - IF ( INFO1 > 0 ) THEN - ! The SVD selected subroutine did not converge. - ! Return with an error code. - INFO = 2 - RETURN - END IF -! - IF ( RWORK(1) == ZERO ) THEN - ! The largest computed singular value of (scaled) - ! X is zero. Return error code -8 - ! (the 8th input variable had an illegal value). - K = 0 - INFO = -8 - CALL XERBLA('ZGEDMD',-INFO) - RETURN - END IF -! - !<3> Determine the numerical rank of the data - ! snapshots matrix X. This depends on the - ! parameters NRNK and TOL. - - SELECT CASE ( NRNK ) - CASE ( -1 ) - K = 1 - DO i = 2, NUMRNK - IF ( ( RWORK(i) <= RWORK(1)*TOL ) .OR. & - ( RWORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE ( -2 ) - K = 1 - DO i = 1, NUMRNK-1 - IF ( ( RWORK(i+1) <= RWORK(i)*TOL ) .OR. & - ( RWORK(i) <= SMALL ) ) EXIT - K = K + 1 - END DO - CASE DEFAULT - K = 1 - DO i = 2, NRNK - IF ( RWORK(i) <= SMALL ) EXIT - K = K + 1 - END DO - END SELECT - ! Now, U = X(1:M,1:K) is the SVD/POD basis for the - ! snapshot data in the input matrix X. - - !<4> Compute the Rayleigh quotient S = U^H * A * U. - ! Depending on the requested outputs, the computation - ! is organized to compute additional auxiliary - ! matrices (for the residuals and refinements). - ! - ! In all formulas below, we need V_k*Sigma_k^(-1) - ! where either V_k is in W(1:N,1:K), or V_k^H is in - ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). - IF ( LSAME(T_OR_N, 'N') ) THEN - DO i = 1, K - CALL ZDSCAL( N, ONE/RWORK(i), W(1,i), 1 ) ! BLAS CALL - ! W(1:N,i) = (ONE/RWORK(i)) * W(1:N,i) ! INTRINSIC - END DO - ELSE - ! This non-unit stride access is due to the fact - ! that ZGESVD, ZGESVDQ and ZGESDD return the - ! adjoint matrix of the right singular vectors. - !DO i = 1, K - ! CALL ZDSCAL( N, ONE/RWORK(i), W(i,1), LDW ) ! BLAS CALL - ! ! W(i,1:N) = (ONE/RWORK(i)) * W(i,1:N) ! INTRINSIC - !END DO - DO i = 1, K - RWORK(N+i) = ONE/RWORK(i) - END DO - DO j = 1, N - DO i = 1, K - W(i,j) = CMPLX(RWORK(N+i),ZERO,KIND=WP)*W(i,j) - END DO - END DO - END IF -! - IF ( WNTREF ) THEN - ! - ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) - ! for computing the refined Ritz vectors - ! (optionally, outside ZGEDMD). - CALL ZGEMM( 'N', T_OR_N, M, K, N, ZONE, Y, LDY, W, & - LDW, ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(CONJG(W(1:K,1:N)))) ! INTRINSIC, for T_OR_N=='C' - ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' - ! - ! At this point Z contains - ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and - ! this is needed for computing the residuals. - ! This matrix is returned in the array B and - ! it can be used to compute refined Ritz vectors. - CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL - ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC - - CALL ZGEMM( 'C', 'N', K, K, M, ZONE, X, LDX, Z, & - LDZ, ZZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(TRANSPOSE(CONJG(X(1:M,1:K))),Z(1:M,1:K)) ! INTRINSIC - ! At this point S = U^H * A * U is the Rayleigh quotient. - ELSE - ! A * U(:,1:K) is not explicitly needed and the - ! computation is organized differently. The Rayleigh - ! quotient is computed more efficiently. - CALL ZGEMM( 'C', 'N', K, N, M, ZONE, X, LDX, Y, LDY, & - ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:K,1:N) = MATMUL( TRANSPOSE(CONJG(X(1:M,1:K))), Y(1:M,1:N) ) ! INTRINSIC - ! - CALL ZGEMM( 'N', T_OR_N, K, K, N, ZONE, Z, LDZ, W, & - LDW, ZZERO, S, LDS ) ! BLAS CALL - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(CONJG(W(1:K,1:N)))) ! INTRINSIC, for T_OR_N=='T' - ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' - ! At this point S = U^H * A * U is the Rayleigh quotient. - ! If the residuals are requested, save scaled V_k into Z. - ! Recall that V_k or V_k^H is stored in W. - IF ( WNTRES .OR. WNTEX ) THEN - IF ( LSAME(T_OR_N, 'N') ) THEN - CALL ZLACPY( 'A', N, K, W, LDW, Z, LDZ ) - ELSE - CALL ZLACPY( 'A', K, N, W, LDW, Z, LDZ ) - END IF - END IF - END IF -! - !<5> Compute the Ritz values and (if requested) the - ! right eigenvectors of the Rayleigh quotient. - ! - CALL ZGEEV( 'N', JOBZL, K, S, LDS, EIGS, W, LDW, & - W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL - ! - ! W(1:K,1:K) contains the eigenvectors of the Rayleigh - ! quotient. See the description of Z. - ! Also, see the description of ZGEEV. - IF ( INFO1 > 0 ) THEN - ! ZGEEV failed to compute the eigenvalues and - ! eigenvectors of the Rayleigh quotient. - INFO = 3 - RETURN - END IF -! - ! <6> Compute the eigenvectors (if requested) and, - ! the residuals (if requested). - ! - IF ( WNTVEC .OR. WNTEX ) THEN - IF ( WNTRES ) THEN - IF ( WNTREF ) THEN - ! Here, if the refinement is requested, we have - ! A*U(:,1:K) already computed and stored in Z. - ! For the residuals, need Y = A * U(:,1;K) * W. - CALL ZGEMM( 'N', 'N', M, K, K, ZONE, Z, LDZ, W, & - LDW, ZZERO, Y, LDY ) ! BLAS CALL - ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC - ! This frees Z; Y contains A * U(:,1:K) * W. - ELSE - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) (or its adjoint) is stored in Z - CALL ZGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & - W, LDW, ZZERO, S, LDS ) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - LDS, ZZERO, Z, LDZ ) - ! Save a copy of Z into Y and free Z for holding - ! the Ritz vectors. - CALL ZLACPY( 'A', M, K, Z, LDZ, Y, LDY ) - IF ( WNTEX ) CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF - ELSE IF ( WNTEX ) THEN - ! Compute S = V_k * Sigma_k^(-1) * W, where - ! V_k * Sigma_k^(-1) is stored in Z - CALL ZGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & - W, LDW, ZZERO, S, LDS ) - ! Then, compute Z = Y * S = - ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = - ! = A * U(:,1:K) * W(1:K,1:K) - CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - LDS, ZZERO, B, LDB ) - ! The above call replaces the following two calls - ! that were used in the developing-testing phase. - ! CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & - ! LDS, ZZERO, Z, LDZ) - ! Save a copy of Z into B and free Z for holding - ! the Ritz vectors. - ! CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) - END IF -! - ! Compute the Ritz vectors - IF ( WNTVEC ) CALL ZGEMM( 'N', 'N', M, K, K, ZONE, X, LDX, W, LDW, & - ZZERO, Z, LDZ ) ! BLAS CALL - ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC -! - IF ( WNTRES ) THEN - DO i = 1, K - CALL ZAXPY( M, -EIGS(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL - ! Y(1:M,i) = Y(1:M,i) - EIGS(i) * Z(1:M,i) ! INTRINSIC - RES(i) = DZNRM2( M, Y(1,i), 1 ) ! BLAS CALL - END DO - END IF - END IF -! - IF ( WHTSVD == 4 ) THEN - RWORK(N+1) = XSCL1 - RWORK(N+2) = XSCL2 - END IF -! -! Successful exit. - IF ( .NOT. BADXY ) THEN - INFO = 0 - ELSE - ! A warning on possible data inconsistency. - ! This should be a rare event. - INFO = 4 - END IF -!............................................................ - RETURN -! ...... - END SUBROUTINE ZGEDMD - +!> \brief \b ZGEDMD computes the Dynamic Mode Decomposition (DMD) for a pair of data snapshot matrices. +! +! =========== DOCUMENTATION =========== +! +! Definition: +! =========== +! +! SUBROUTINE ZGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & +! M, N, X, LDX, Y, LDY, NRNK, TOL, & +! K, EIGS, Z, LDZ, RES, B, LDB, & +! W, LDW, S, LDS, ZWORK, LZWORK, & +! RWORK, LRWORK, IWORK, LIWORK, INFO ) +!...... +! USE, INTRINSIC :: iso_fortran_env, only: real64 +! IMPLICIT NONE +! INTEGER, PARAMETER :: WP = real64 +! +!...... +! Scalar arguments +! CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF +! INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & +! NRNK, LDZ, LDB, LDW, LDS, & +! LIWORK, LRWORK, LZWORK +! INTEGER, INTENT(OUT) :: K, INFO +! REAL(KIND=WP), INTENT(IN) :: TOL +! Array arguments +! COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) +! COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & +! W(LDW,*), S(LDS,*) +! COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) +! COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) +! REAL(KIND=WP), INTENT(OUT) :: RES(*) +! REAL(KIND=WP), INTENT(OUT) :: RWORK(*) +! INTEGER, INTENT(OUT) :: IWORK(*) +! +!............................................................ +!> \par Purpose: +! ============= +!> \verbatim +!> ZGEDMD computes the Dynamic Mode Decomposition (DMD) for +!> a pair of data snapshot matrices. For the input matrices +!> X and Y such that Y = A*X with an unaccessible matrix +!> A, ZGEDMD computes a certain number of Ritz pairs of A using +!> the standard Rayleigh-Ritz extraction from a subspace of +!> range(X) that is determined using the leading left singular +!> vectors of X. Optionally, ZGEDMD returns the residuals +!> of the computed Ritz pairs, the information needed for +!> a refinement of the Ritz vectors, or the eigenvectors of +!> the Exact DMD. +!> For further details see the references listed +!> below. For more details of the implementation see [3]. +!> \endverbatim +!............................................................ +!> \par References: +! ================ +!> \verbatim +!> [1] P. Schmid: Dynamic mode decomposition of numerical +!> and experimental data, +!> Journal of Fluid Mechanics 656, 5-28, 2010. +!> [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal +!> decompositions: analysis and enhancements, +!> SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018. +!> [3] Z. Drmac: A LAPACK implementation of the Dynamic +!> Mode Decomposition I. Technical report. AIMDyn Inc. +!> and LAPACK Working Note 298. +!> [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L. +!> Brunton, N. Kutz: On Dynamic Mode Decomposition: +!> Theory and Applications, Journal of Computational +!> Dynamics 1(2), 391 -421, 2014. +!> \endverbatim +!...................................................................... +!> \par Developed and supported by: +! ================================ +!> \verbatim +!> Developed and coded by Zlatko Drmac, Faculty of Science, +!> University of Zagreb; drmac@math.hr +!> In cooperation with +!> AIMdyn Inc., Santa Barbara, CA. +!> and supported by +!> - DARPA SBIR project "Koopman Operator-Based Forecasting +!> for Nonstationary Processes from Near-Term, Limited +!> Observational Data" Contract No: W31P4Q-21-C-0007 +!> - DARPA PAI project "Physics-Informed Machine Learning +!> Methodologies" Contract No: HR0011-18-9-0033 +!> - DARPA MoDyL project "A Data-Driven, Operator-Theoretic +!> Framework for Space-Time Analysis of Process Dynamics" +!> Contract No: HR0011-16-C-0116 +!> Any opinions, findings and conclusions or recommendations +!> expressed in this material are those of the author and +!> do not necessarily reflect the views of the DARPA SBIR +!> Program Office +!> \endverbatim +!...................................................................... +!> \par Distribution Statement A: +! ============================== +!> \verbatim +!> Approved for Public Release, Distribution Unlimited. +!> Cleared by DARPA on September 29, 2022 +!> \endverbatim +!............................................................ +! Arguments +! ========= +! +!> \param[in] JOBS +!> \verbatim +!> JOBS (input) CHARACTER*1 +!> Determines whether the initial data snapshots are scaled +!> by a diagonal matrix. +!> 'S' :: The data snapshots matrices X and Y are multiplied +!> with a diagonal matrix D so that X*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'C' :: The snapshots are scaled as with the 'S' option. +!> If it is found that an i-th column of X is zero +!> vector and the corresponding i-th column of Y is +!> non-zero, then the i-th column of Y is set to +!> zero and a warning flag is raised. +!> 'Y' :: The data snapshots matrices X and Y are multiplied +!> by a diagonal matrix D so that Y*D has unit +!> nonzero columns (in the Euclidean 2-norm) +!> 'N' :: No data scaling. +!> \endverbatim +!..... +!> \param[in] JOBZ +!> \verbatim +!> JOBZ (input) CHARACTER*1 +!> Determines whether the eigenvectors (Koopman modes) will +!> be computed. +!> 'V' :: The eigenvectors (Koopman modes) will be computed +!> and returned in the matrix Z. +!> See the description of Z. +!> 'F' :: The eigenvectors (Koopman modes) will be returned +!> in factored form as the product X(:,1:K)*W, where X +!> contains a POD basis (leading left singular vectors +!> of the data matrix X) and W contains the eigenvectors +!> of the corresponding Rayleigh quotient. +!> See the descriptions of K, X, W, Z. +!> 'N' :: The eigenvectors are not computed. +!> \endverbatim +!..... +!> \param[in] JOBR +!> \verbatim +!> JOBR (input) CHARACTER*1 +!> Determines whether to compute the residuals. +!> 'R' :: The residuals for the computed eigenpairs will be +!> computed and stored in the array RES. +!> See the description of RES. +!> For this option to be legal, JOBZ must be 'V'. +!> 'N' :: The residuals are not computed. +!> \endverbatim +!..... +!> \param[in] JOBF +!> \verbatim +!> JOBF (input) CHARACTER*1 +!> Specifies whether to store information needed for post- +!> processing (e.g. computing refined Ritz vectors) +!> 'R' :: The matrix needed for the refinement of the Ritz +!> vectors is computed and stored in the array B. +!> See the description of B. +!> 'E' :: The unscaled eigenvectors of the Exact DMD are +!> computed and returned in the array B. See the +!> description of B. +!> 'N' :: No eigenvector refinement data is computed. +!> \endverbatim +!..... +!> \param[in] WHTSVD +!> \verbatim +!> WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 } +!> Allows for a selection of the SVD algorithm from the +!> LAPACK library. +!> 1 :: ZGESVD (the QR SVD algorithm) +!> 2 :: ZGESDD (the Divide and Conquer algorithm; if enough +!> workspace available, this is the fastest option) +!> 3 :: ZGESVDQ (the preconditioned QR SVD ; this and 4 +!> are the most accurate options) +!> 4 :: ZGEJSV (the preconditioned Jacobi SVD; this and 3 +!> are the most accurate options) +!> For the four methods above, a significant difference in +!> the accuracy of small singular values is possible if +!> the snapshots vary in norm so that X is severely +!> ill-conditioned. If small (smaller than EPS*||X||) +!> singular values are of interest and JOBS=='N', then +!> the options (3, 4) give the most accurate results, where +!> the option 4 is slightly better and with stronger +!> theoretical background. +!> If JOBS=='S', i.e. the columns of X will be normalized, +!> then all methods give nearly equally accurate results. +!> \endverbatim +!..... +!> \param[in] M +!> \verbatim +!> M (input) INTEGER, M>= 0 +!> The state space dimension (the row dimension of X, Y). +!> \endverbatim +!..... +!> \param[in] N +!> \verbatim +!> N (input) INTEGER, 0 <= N <= M +!> The number of data snapshot pairs +!> (the number of columns of X and Y). +!> \endverbatim +!..... +!> \param[in,out] X +!> \verbatim +!> X (input/output) COMPLEX(KIND=WP) M-by-N array +!> > On entry, X contains the data snapshot matrix X. It is +!> assumed that the column norms of X are in the range of +!> the normalized floating point numbers. +!> < On exit, the leading K columns of X contain a POD basis, +!> i.e. the leading K left singular vectors of the input +!> data matrix X, U(:,1:K). All N columns of X contain all +!> left singular vectors of the input matrix X. +!> See the descriptions of K, Z and W. +!> \endverbatim +!..... +!> \param[in] LDX +!> \verbatim +!> LDX (input) INTEGER, LDX >= M +!> The leading dimension of the array X. +!> \endverbatim +!..... +!> \param[in,out] Y +!> \verbatim +!> Y (input/workspace/output) COMPLEX(KIND=WP) M-by-N array +!> > On entry, Y contains the data snapshot matrix Y +!> < On exit, +!> If JOBR == 'R', the leading K columns of Y contain +!> the residual vectors for the computed Ritz pairs. +!> See the description of RES. +!> If JOBR == 'N', Y contains the original input data, +!> scaled according to the value of JOBS. +!> \endverbatim +!..... +!> \param[in] LDY +!> \verbatim +!> LDY (input) INTEGER , LDY >= M +!> The leading dimension of the array Y. +!> \endverbatim +!..... +!> \param[in] NRNK +!> \verbatim +!> NRNK (input) INTEGER +!> Determines the mode how to compute the numerical rank, +!> i.e. how to truncate small singular values of the input +!> matrix X. On input, if +!> NRNK = -1 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(1) +!> This option is recommended. +!> NRNK = -2 :: i-th singular value sigma(i) is truncated +!> if sigma(i) <= TOL*sigma(i-1) +!> This option is included for R&D purposes. +!> It requires highly accurate SVD, which +!> may not be feasible. +!> The numerical rank can be enforced by using positive +!> value of NRNK as follows: +!> 0 < NRNK <= N :: at most NRNK largest singular values +!> will be used. If the number of the computed nonzero +!> singular values is less than NRNK, then only those +!> nonzero values will be used and the actually used +!> dimension is less than NRNK. The actual number of +!> the nonzero singular values is returned in the variable +!> K. See the descriptions of TOL and K. +!> \endverbatim +!..... +!> \param[in] TOL +!> \verbatim +!> TOL (input) REAL(KIND=WP), 0 <= TOL < 1 +!> The tolerance for truncating small singular values. +!> See the description of NRNK. +!> \endverbatim +!..... +!> \param[out] K +!> \verbatim +!> K (output) INTEGER, 0 <= K <= N +!> The dimension of the POD basis for the data snapshot +!> matrix X and the number of the computed Ritz pairs. +!> The value of K is determined according to the rule set +!> by the parameters NRNK and TOL. +!> See the descriptions of NRNK and TOL. +!> \endverbatim +!..... +!> \param[out] EIGS +!> \verbatim +!> EIGS (output) COMPLEX(KIND=WP) N-by-1 array +!> The leading K (K<=N) entries of EIGS contain +!> the computed eigenvalues (Ritz values). +!> See the descriptions of K, and Z. +!> \endverbatim +!..... +!> \param[out] Z +!> \verbatim +!> Z (workspace/output) COMPLEX(KIND=WP) M-by-N array +!> If JOBZ =='V' then Z contains the Ritz vectors. Z(:,i) +!> is an eigenvector of the i-th Ritz value; ||Z(:,i)||_2=1. +!> If JOBZ == 'F', then the Z(:,i)'s are given implicitly as +!> the columns of X(:,1:K)*W(1:K,1:K), i.e. X(:,1:K)*W(:,i) +!> is an eigenvector corresponding to EIGS(i). The columns +!> of W(1:k,1:K) are the computed eigenvectors of the +!> K-by-K Rayleigh quotient. +!> See the descriptions of EIGS, X and W. +!> \endverbatim +!..... +!> \param[in] LDZ +!> \verbatim +!> LDZ (input) INTEGER , LDZ >= M +!> The leading dimension of the array Z. +!> \endverbatim +!..... +!> \param[out] RES +!> \verbatim +!> RES (output) REAL(KIND=WP) N-by-1 array +!> RES(1:K) contains the residuals for the K computed +!> Ritz pairs, +!> RES(i) = || A * Z(:,i) - EIGS(i)*Z(:,i))||_2. +!> See the description of EIGS and Z. +!> \endverbatim +!..... +!> \param[out] B +!> \verbatim +!> B (output) COMPLEX(KIND=WP) M-by-N array. +!> IF JOBF =='R', B(1:M,1:K) contains A*U(:,1:K), and can +!> be used for computing the refined vectors; see further +!> details in the provided references. +!> If JOBF == 'E', B(1:M,1:K) contains +!> A*U(:,1:K)*W(1:K,1:K), which are the vectors from the +!> Exact DMD, up to scaling by the inverse eigenvalues. +!> If JOBF =='N', then B is not referenced. +!> See the descriptions of X, W, K. +!> \endverbatim +!..... +!> \param[in] LDB +!> \verbatim +!> LDB (input) INTEGER, LDB >= M +!> The leading dimension of the array B. +!> \endverbatim +!..... +!> \param[out] W +!> \verbatim +!> W (workspace/output) COMPLEX(KIND=WP) N-by-N array +!> On exit, W(1:K,1:K) contains the K computed +!> eigenvectors of the matrix Rayleigh quotient. +!> The Ritz vectors (returned in Z) are the +!> product of X (containing a POD basis for the input +!> matrix X) and W. See the descriptions of K, S, X and Z. +!> W is also used as a workspace to temporarily store the +!> right singular vectors of X. +!> \endverbatim +!..... +!> \param[in] LDW +!> \verbatim +!> LDW (input) INTEGER, LDW >= N +!> The leading dimension of the array W. +!> \endverbatim +!..... +!> \param[out] S +!> \verbatim +!> S (workspace/output) COMPLEX(KIND=WP) N-by-N array +!> The array S(1:K,1:K) is used for the matrix Rayleigh +!> quotient. This content is overwritten during +!> the eigenvalue decomposition by ZGEEV. +!> See the description of K. +!> \endverbatim +!..... +!> \param[in] LDS +!> \verbatim +!> LDS (input) INTEGER, LDS >= N +!> The leading dimension of the array S. +!> \endverbatim +!..... +!> \param[out] ZWORK +!> \verbatim +!> ZWORK (workspace/output) COMPLEX(KIND=WP) LZWORK-by-1 array +!> ZWORK is used as complex workspace in the complex SVD, as +!> specified by WHTSVD (1,2, 3 or 4) and for ZGEEV for computing +!> the eigenvalues of a Rayleigh quotient. +!> If the call to ZGEDMD is only workspace query, then +!> ZWORK(1) contains the minimal complex workspace length and +!> ZWORK(2) is the optimal complex workspace length. +!> Hence, the length of work is at least 2. +!> See the description of LZWORK. +!> \endverbatim +!..... +!> \param[in] LZWORK +!> \verbatim +!> LZWORK (input) INTEGER +!> The minimal length of the workspace vector ZWORK. +!> LZWORK is calculated as MAX(LZWORK_SVD, LZWORK_ZGEEV), +!> where LZWORK_ZGEEV = MAX( 1, 2*N ) and the minimal +!> LZWORK_SVD is calculated as follows +!> If WHTSVD == 1 :: ZGESVD :: +!> LZWORK_SVD = MAX(1,2*MIN(M,N)+MAX(M,N)) +!> If WHTSVD == 2 :: ZGESDD :: +!> LZWORK_SVD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) +!> If WHTSVD == 3 :: ZGESVDQ :: +!> LZWORK_SVD = obtainable by a query +!> If WHTSVD == 4 :: ZGEJSV :: +!> LZWORK_SVD = obtainable by a query +!> If on entry LZWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths and returns them in +!> LZWORK(1) and LZWORK(2), respectively. +!> \endverbatim +!..... +!> \param[out] RWORK +!> \verbatim +!> RWORK (workspace/output) REAL(KIND=WP) LRWORK-by-1 array +!> On exit, RWORK(1:N) contains the singular values of +!> X (for JOBS=='N') or column scaled X (JOBS=='S', 'C'). +!> If WHTSVD==4, then RWORK(N+1) and RWORK(N+2) contain +!> scaling factor RWORK(N+2)/RWORK(N+1) used to scale X +!> and Y to avoid overflow in the SVD of X. +!> This may be of interest if the scaling option is off +!> and as many as possible smallest eigenvalues are +!> desired to the highest feasible accuracy. +!> If the call to ZGEDMD is only workspace query, then +!> RWORK(1) contains the minimal workspace length. +!> See the description of LRWORK. +!> \endverbatim +!..... +!> \param[in] LRWORK +!> \verbatim +!> LRWORK (input) INTEGER +!> The minimal length of the workspace vector RWORK. +!> LRWORK is calculated as follows: +!> LRWORK = MAX(1, N+LRWORK_SVD,N+LRWORK_ZGEEV), where +!> LRWORK_ZGEEV = MAX(1,2*N) and RWORK_SVD is the real workspace +!> for the SVD subroutine determined by the input parameter +!> WHTSVD. +!> If WHTSVD == 1 :: ZGESVD :: +!> LRWORK_SVD = 5*MIN(M,N) +!> If WHTSVD == 2 :: ZGESDD :: +!> LRWORK_SVD = MAX(5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), +!> 2*MAX(M,N)*MIN(M,N)+2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) +!> If WHTSVD == 3 :: ZGESVDQ :: +!> LRWORK_SVD = obtainable by a query +!> If WHTSVD == 4 :: ZGEJSV :: +!> LRWORK_SVD = obtainable by a query +!> If on entry LRWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> real workspace length and returns it in RWORK(1). +!> \endverbatim +!..... +!> \param[out] IWORK +!> \verbatim +!> IWORK (workspace/output) INTEGER LIWORK-by-1 array +!> Workspace that is required only if WHTSVD equals +!> 2 , 3 or 4. (See the description of WHTSVD). +!> If on entry LWORK =-1 or LIWORK=-1, then the +!> minimal length of IWORK is computed and returned in +!> IWORK(1). See the description of LIWORK. +!> \endverbatim +!..... +!> \param[in] LIWORK +!> \verbatim +!> LIWORK (input) INTEGER +!> The minimal length of the workspace vector IWORK. +!> If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1 +!> If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N)) +!> If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1) +!> If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N) +!> If on entry LIWORK = -1, then a workspace query is +!> assumed and the procedure only computes the minimal +!> and the optimal workspace lengths for ZWORK, RWORK and +!> IWORK. See the descriptions of ZWORK, RWORK and IWORK. +!> \endverbatim +!..... +!> \param[out] INFO +!> \verbatim +!> INFO (output) INTEGER +!> -i < 0 :: On entry, the i-th argument had an +!> illegal value +!> = 0 :: Successful return. +!> = 1 :: Void input. Quick exit (M=0 or N=0). +!> = 2 :: The SVD computation of X did not converge. +!> Suggestion: Check the input data and/or +!> repeat with different WHTSVD. +!> = 3 :: The computation of the eigenvalues did not +!> converge. +!> = 4 :: If data scaling was requested on input and +!> the procedure found inconsistency in the data +!> such that for some column index i, +!> X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set +!> to zero if JOBS=='C'. The computation proceeds +!> with original or modified data and warning +!> flag is set with INFO=4. +!> \endverbatim +! +! Authors: +! ======== +! +!> \author Zlatko Drmac +! +!> \ingroup gedmd +! +!............................................................. +!............................................................. + SUBROUTINE ZGEDMD( JOBS, JOBZ, JOBR, JOBF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, EIGS, Z, LDZ, RES, B, LDB, & + W, LDW, S, LDS, ZWORK, LZWORK, & + RWORK, LRWORK, IWORK, LIWORK, INFO ) +! +! -- LAPACK driver routine -- +! +! -- LAPACK is a software package provided by University of -- +! -- Tennessee, University of California Berkeley, University of -- +! -- Colorado Denver and NAG Ltd.. -- +! +!..... + USE, INTRINSIC :: iso_fortran_env, only: real64 + IMPLICIT NONE + INTEGER, PARAMETER :: WP = real64 +! +! Scalar arguments +! ~~~~~~~~~~~~~~~~ + CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBF + INTEGER, INTENT(IN) :: WHTSVD, M, N, LDX, LDY, & + NRNK, LDZ, LDB, LDW, LDS, & + LIWORK, LRWORK, LZWORK + INTEGER, INTENT(OUT) :: K, INFO + REAL(KIND=WP), INTENT(IN) :: TOL +! +! Array arguments +! ~~~~~~~~~~~~~~~ + COMPLEX(KIND=WP), INTENT(INOUT) :: X(LDX,*), Y(LDY,*) + COMPLEX(KIND=WP), INTENT(OUT) :: Z(LDZ,*), B(LDB,*), & + W(LDW,*), S(LDS,*) + COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*) + COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*) + REAL(KIND=WP), INTENT(OUT) :: RES(*) + REAL(KIND=WP), INTENT(OUT) :: RWORK(*) + INTEGER, INTENT(OUT) :: IWORK(*) +! +! Parameters +! ~~~~~~~~~~ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP + COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP ) + COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP ) +! +! Local scalars +! ~~~~~~~~~~~~~ + REAL(KIND=WP) :: OFL, ROOTSC, SCALE, SMALL, & + SSUM, XSCL1, XSCL2, TBIG + INTEGER :: i, j, IMINWR, INFO1, INFO2, & + LWRKEV, LWRSDD, LWRSVD, LWRSVJ, & + LWRSVQ, MLWORK, MWRKEV, MWRSDD, & + MWRSVD, MWRSVJ, MWRSVQ, NUMRNK, & + OLWORK, MLRWRK + LOGICAL :: BADXY, LQUERY, SCCOLX, SCCOLY, & + WNTEX, WNTREF, WNTRES, WNTVEC + CHARACTER :: JOBZL, T_OR_N + CHARACTER :: JSVOPT +! +! Local arrays +! ~~~~~~~~~~~~ + REAL(KIND=WP) :: RDUMMY(2) +! +! External functions (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~ + REAL(KIND=WP) ZLANGE, DLAMCH, DZNRM2 + EXTERNAL ZLANGE, DLAMCH, DZNRM2, IZAMAX + INTEGER IZAMAX + LOGICAL DISNAN, LSAME + EXTERNAL DISNAN, LSAME +! +! External subroutines (BLAS and LAPACK) +! ~~~~~~~~~~~~~~~~~~~~ + EXTERNAL ZAXPY, ZGEMM, ZDSCAL + EXTERNAL ZGEEV, ZGEJSV, ZGESDD, ZGESVD, ZGESVDQ, & + ZLACPY, ZLASCL, ZLASSQ, XERBLA +! +! Intrinsic functions +! ~~~~~~~~~~~~~~~~~~~ + INTRINSIC DBLE, INT, MAX, SQRT +!............................................................ +! +! Test the input arguments +! + WNTRES = LSAME(JOBR,'R') + SCCOLX = LSAME(JOBS,'S') .OR. LSAME(JOBS,'C') + SCCOLY = LSAME(JOBS,'Y') + WNTVEC = LSAME(JOBZ,'V') + WNTREF = LSAME(JOBF,'R') + WNTEX = LSAME(JOBF,'E') + INFO = 0 + LQUERY = ( ( LZWORK == -1 ) .OR. ( LIWORK == -1 ) & + .OR. ( LRWORK == -1 ) ) +! + IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. & + LSAME(JOBS,'N')) ) THEN + INFO = -1 + ELSE IF ( .NOT. (WNTVEC .OR. LSAME(JOBZ,'N') & + .OR. LSAME(JOBZ,'F')) ) THEN + INFO = -2 + ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. & + ( WNTRES .AND. (.NOT.WNTVEC) ) ) THEN + INFO = -3 + ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. & + LSAME(JOBF,'N') ) ) THEN + INFO = -4 + ELSE IF ( .NOT.((WHTSVD == 1) .OR. (WHTSVD == 2) .OR. & + (WHTSVD == 3) .OR. (WHTSVD == 4) )) THEN + INFO = -5 + ELSE IF ( M < 0 ) THEN + INFO = -6 + ELSE IF ( ( N < 0 ) .OR. ( N > M ) ) THEN + INFO = -7 + ELSE IF ( LDX < M ) THEN + INFO = -9 + ELSE IF ( LDY < M ) THEN + INFO = -11 + ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. & + ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN + INFO = -12 + ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN + INFO = -13 + ELSE IF ( LDZ < M ) THEN + INFO = -17 + ELSE IF ( (WNTREF .OR. WNTEX ) .AND. ( LDB < M ) ) THEN + INFO = -20 + ELSE IF ( LDW < N ) THEN + INFO = -22 + ELSE IF ( LDS < N ) THEN + INFO = -24 + END IF +! + IF ( INFO == 0 ) THEN + ! Compute the minimal and the optimal workspace + ! requirements. Simulate running the code and + ! determine minimal and optimal sizes of the + ! workspace at any moment of the run. + IF ( N == 0 ) THEN + ! Quick return. All output except K is void. + ! INFO=1 signals the void input. + ! In case of a workspace query, the default + ! minimal workspace lengths are returned. + IF ( LQUERY ) THEN + IWORK(1) = 1 + RWORK(1) = 1 + ZWORK(1) = 2 + ZWORK(2) = 2 + ELSE + K = 0 + END IF + INFO = 1 + RETURN + END IF + + IMINWR = 1 + MLRWRK = MAX(1,N) + MLWORK = 2 + OLWORK = 2 + SELECT CASE ( WHTSVD ) + CASE (1) + ! The following is specified as the minimal + ! length of WORK in the definition of ZGESVD: + ! MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) + MWRSVD = MAX(1,2*MIN(M,N)+MAX(M,N)) + MLWORK = MAX(MLWORK,MWRSVD) + MLRWRK = MAX(MLRWRK,N + 5*MIN(M,N)) + IF ( LQUERY ) THEN + CALL ZGESVD( 'O', 'S', M, N, X, LDX, RWORK, & + B, LDB, W, LDW, ZWORK, -1, RDUMMY, INFO1 ) + LWRSVD = INT( ZWORK(1) ) + OLWORK = MAX(OLWORK,LWRSVD) + END IF + CASE (2) + ! The following is specified as the minimal + ! length of WORK in the definition of ZGESDD: + ! MWRSDD = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). + ! RWORK length: 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N) + ! In LAPACK 3.10.1 RWORK is defined differently. + ! Below we take max over the two versions. + ! IMINWR = 8*MIN(M,N) + MWRSDD = 2*MIN(M,N)*MIN(M,N)+2*MIN(M,N)+MAX(M,N) + MLWORK = MAX(MLWORK,MWRSDD) + IMINWR = 8*MIN(M,N) + MLRWRK = MAX( MLRWRK, N + & + MAX( 5*MIN(M,N)*MIN(M,N)+7*MIN(M,N), & + 5*MIN(M,N)*MIN(M,N)+5*MIN(M,N), & + 2*MAX(M,N)*MIN(M,N)+ & + 2*MIN(M,N)*MIN(M,N)+MIN(M,N) ) ) + IF ( LQUERY ) THEN + CALL ZGESDD( 'O', M, N, X, LDX, RWORK, B,LDB,& + W, LDW, ZWORK, -1, RDUMMY, IWORK, INFO1 ) + LWRSDD = MAX( MWRSDD,INT( ZWORK(1) )) + ! Possible bug in ZGESDD optimal workspace size. + OLWORK = MAX(OLWORK,LWRSDD) + END IF + CASE (3) + CALL ZGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, RWORK, Z, LDZ, W, LDW, NUMRNK, & + IWORK, -1, ZWORK, -1, RDUMMY, -1, INFO1 ) + IMINWR = IWORK(1) + MWRSVQ = INT(ZWORK(2)) + MLWORK = MAX(MLWORK,MWRSVQ) + MLRWRK = MAX(MLRWRK,N + INT(RDUMMY(1))) + IF ( LQUERY ) THEN + LWRSVQ = INT(ZWORK(1)) + OLWORK = MAX(OLWORK,LWRSVQ) + END IF + CASE (4) + JSVOPT = 'J' + CALL ZGEJSV( 'F', 'U', JSVOPT, 'R', 'N', 'P', M, & + N, X, LDX, RWORK, Z, LDZ, W, LDW, & + ZWORK, -1, RDUMMY, -1, IWORK, INFO1 ) + IMINWR = IWORK(1) + MWRSVJ = INT(ZWORK(2)) + MLWORK = MAX(MLWORK,MWRSVJ) + MLRWRK = MAX(MLRWRK,N + MAX(7,INT(RDUMMY(1)))) + IF ( LQUERY ) THEN + LWRSVJ = INT(ZWORK(1)) + OLWORK = MAX(OLWORK,LWRSVJ) + END IF + END SELECT + IF ( WNTVEC .OR. WNTEX .OR. LSAME(JOBZ,'F') ) THEN + JOBZL = 'V' + ELSE + JOBZL = 'N' + END IF + ! Workspace calculation to the ZGEEV call + MWRKEV = MAX( 1, 2*N ) + MLWORK = MAX(MLWORK,MWRKEV) + MLRWRK = MAX(MLRWRK,N+2*N) + IF ( LQUERY ) THEN + CALL ZGEEV( 'N', JOBZL, N, S, LDS, EIGS, & + W, LDW, W, LDW, ZWORK, -1, RWORK, INFO1 ) + LWRKEV = INT(ZWORK(1)) + OLWORK = MAX( OLWORK, LWRKEV ) + END IF +! + IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -30 + IF ( LRWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -28 + IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -26 + + END IF +! + IF( INFO /= 0 ) THEN + CALL XERBLA( 'ZGEDMD', -INFO ) + RETURN + ELSE IF ( LQUERY ) THEN +! Return minimal and optimal workspace sizes + IWORK(1) = IMINWR + RWORK(1) = MLRWRK + ZWORK(1) = MLWORK + ZWORK(2) = OLWORK + RETURN + END IF +!............................................................ +! + OFL = DLAMCH('O') + SMALL = DLAMCH('S') + BADXY = .FALSE. +! +! <1> Optional scaling of the snapshots (columns of X, Y) +! ========================================================== + IF ( SCCOLX ) THEN + ! The columns of X will be normalized. + ! To prevent overflows, the column norms of X are + ! carefully computed using ZLASSQ. + K = 0 + DO i = 1, N + !WORK(i) = DZNRM2( M, X(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL ZLASSQ( M, X(1,i), 1, SCALE, SSUM ) + IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN + K = 0 + INFO = -8 + CALL XERBLA('ZGEDMD',-INFO) + END IF + IF ( (SCALE /= ZERO) .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of X(:,i) overflows. First, X(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||X(:,i)||_2. +! Next, the norm of X(:,i) is stored without +! overflow as RWORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of X(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL ZLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, X(1,i), LDX, INFO2 ) + RWORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) + ELSE +! X(:,i) will be scaled to unit 2-norm + RWORK(i) = SCALE * ROOTSC + CALL ZLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & + X(1,i), LDX, INFO2 ) ! LAPACK CALL +! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC + END IF + ELSE + RWORK(i) = ZERO + K = K + 1 + END IF + END DO + IF ( K == N ) THEN + ! All columns of X are zero. Return error code -8. + ! (the 8th input variable had an illegal value) + K = 0 + INFO = -8 + CALL XERBLA('ZGEDMD',-INFO) + RETURN + END IF + DO i = 1, N +! Now, apply the same scaling to the columns of Y. + IF ( RWORK(i) > ZERO ) THEN + CALL ZDSCAL( M, ONE/RWORK(i), Y(1,i), 1 ) ! BLAS CALL +! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC + ELSE IF ( RWORK(i) < ZERO ) THEN + CALL ZLASCL( 'G', 0, 0, -RWORK(i), & + ONE/DBLE(M), M, 1, Y(1,i), LDY, INFO2 ) ! LAPACK CALL + ELSE IF ( ABS(Y(IZAMAX(M, Y(1,i),1),i )) & + /= ZERO ) THEN +! X(:,i) is zero vector. For consistency, +! Y(:,i) should also be zero. If Y(:,i) is not +! zero, then the data might be inconsistent or +! corrupted. If JOBS == 'C', Y(:,i) is set to +! zero and a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + IF ( LSAME(JOBS,'C')) & + CALL ZDSCAL( M, ZERO, Y(1,i), 1 ) ! BLAS CALL + END IF + END DO + END IF + ! + IF ( SCCOLY ) THEN + ! The columns of Y will be normalized. + ! To prevent overflows, the column norms of Y are + ! carefully computed using ZLASSQ. + DO i = 1, N + !RWORK(i) = DZNRM2( M, Y(1,i), 1 ) + SSUM = ONE + SCALE = ZERO + CALL ZLASSQ( M, Y(1,i), 1, SCALE, SSUM ) + IF ( DISNAN(SCALE) .OR. DISNAN(SSUM) ) THEN + K = 0 + INFO = -10 + CALL XERBLA('ZGEDMD',-INFO) + END IF + IF ( SCALE /= ZERO .AND. (SSUM /= ZERO) ) THEN + ROOTSC = SQRT(SSUM) + TBIG = OFL + IF ( ROOTSC .GT. ONE ) TBIG = OFL / ROOTSC + IF ( SCALE .GE. TBIG ) THEN +! Norm of Y(:,i) overflows. First, Y(:,i) +! is scaled by +! ( ONE / ROOTSC ) / SCALE = 1/||Y(:,i)||_2. +! Next, the norm of Y(:,i) is stored without +! overflow as RWORK(i) = - SCALE * (ROOTSC/M), +! the minus sign indicating the 1/M factor. +! Scaling is performed without overflow, and +! underflow may occur in the smallest entries +! of Y(:,i). The relative backward and forward +! errors are small in the ell_2 norm. + CALL ZLASCL( 'G', 0, 0, SCALE, ONE/ROOTSC, & + M, 1, Y(1,i), LDY, INFO2 ) + RWORK(i) = - SCALE * ( ROOTSC / DBLE(M) ) + ELSE +! Y(:,i) will be scaled to unit 2-norm + RWORK(i) = SCALE * ROOTSC + CALL ZLASCL( 'G',0, 0, RWORK(i), ONE, M, 1, & + Y(1,i), LDY, INFO2 ) ! LAPACK CALL +! Y(1:M,i) = (ONE/RWORK(i)) * Y(1:M,i) ! INTRINSIC + END IF + ELSE + RWORK(i) = ZERO + END IF + END DO + DO i = 1, N +! Now, apply the same scaling to the columns of X. + IF ( RWORK(i) > ZERO ) THEN + CALL ZDSCAL( M, ONE/RWORK(i), X(1,i), 1 ) ! BLAS CALL +! X(1:M,i) = (ONE/RWORK(i)) * X(1:M,i) ! INTRINSIC + ELSE IF ( RWORK(i) < ZERO ) THEN + CALL ZLASCL( 'G', 0, 0, -RWORK(i), & + ONE/DBLE(M), M, 1, X(1,i), LDX, INFO2 ) ! LAPACK CALL + ELSE IF ( ABS(X(IZAMAX(M, X(1,i),1),i )) & + /= ZERO ) THEN +! Y(:,i) is zero vector. If X(:,i) is not +! zero, then a warning flag is raised. +! The computation continues but the +! situation will be reported in the output. + BADXY = .TRUE. + END IF + END DO + END IF +! +! <2> SVD of the data snapshot matrix X. +! ===================================== +! The left singular vectors are stored in the array X. +! The right singular vectors are in the array W. +! The array W will later on contain the eigenvectors +! of a Rayleigh quotient. + NUMRNK = N + SELECT CASE ( WHTSVD ) + CASE (1) + CALL ZGESVD( 'O', 'S', M, N, X, LDX, RWORK, B, & + LDB, W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL + T_OR_N = 'C' + CASE (2) + CALL ZGESDD( 'O', M, N, X, LDX, RWORK, B, LDB, W, & + LDW, ZWORK, LZWORK, RWORK(N+1), IWORK, INFO1 ) ! LAPACK CALL + T_OR_N = 'C' + CASE (3) + CALL ZGESVDQ( 'H', 'P', 'N', 'R', 'R', M, N, & + X, LDX, RWORK, Z, LDZ, W, LDW, & + NUMRNK, IWORK, LIWORK, ZWORK, & + LZWORK, RWORK(N+1), LRWORK-N, INFO1) ! LAPACK CALL + CALL ZLACPY( 'A', M, NUMRNK, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'C' + CASE (4) + CALL ZGEJSV( 'F', 'U', JSVOPT, 'R', 'N', 'P', M, & + N, X, LDX, RWORK, Z, LDZ, W, LDW, & + ZWORK, LZWORK, RWORK(N+1), LRWORK-N, IWORK, INFO1 ) ! LAPACK CALL + CALL ZLACPY( 'A', M, N, Z, LDZ, X, LDX ) ! LAPACK CALL + T_OR_N = 'N' + XSCL1 = RWORK(N+1) + XSCL2 = RWORK(N+2) + IF ( XSCL1 /= XSCL2 ) THEN + ! This is an exceptional situation. If the + ! data matrices are not scaled and the + ! largest singular value of X overflows. + ! In that case ZGEJSV can return the SVD + ! in scaled form. The scaling factor can be used + ! to rescale the data (X and Y). + CALL ZLASCL( 'G', 0, 0, XSCL1, XSCL2, M, N, Y, LDY, INFO2 ) + END IF + END SELECT +! + IF ( INFO1 > 0 ) THEN + ! The SVD selected subroutine did not converge. + ! Return with an error code. + INFO = 2 + RETURN + END IF +! + IF ( RWORK(1) == ZERO ) THEN + ! The largest computed singular value of (scaled) + ! X is zero. Return error code -8 + ! (the 8th input variable had an illegal value). + K = 0 + INFO = -8 + CALL XERBLA('ZGEDMD',-INFO) + RETURN + END IF +! + !<3> Determine the numerical rank of the data + ! snapshots matrix X. This depends on the + ! parameters NRNK and TOL. + + SELECT CASE ( NRNK ) + CASE ( -1 ) + K = 1 + DO i = 2, NUMRNK + IF ( ( RWORK(i) <= RWORK(1)*TOL ) .OR. & + ( RWORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE ( -2 ) + K = 1 + DO i = 1, NUMRNK-1 + IF ( ( RWORK(i+1) <= RWORK(i)*TOL ) .OR. & + ( RWORK(i) <= SMALL ) ) EXIT + K = K + 1 + END DO + CASE DEFAULT + K = 1 + DO i = 2, NRNK + IF ( RWORK(i) <= SMALL ) EXIT + K = K + 1 + END DO + END SELECT + ! Now, U = X(1:M,1:K) is the SVD/POD basis for the + ! snapshot data in the input matrix X. + + !<4> Compute the Rayleigh quotient S = U^H * A * U. + ! Depending on the requested outputs, the computation + ! is organized to compute additional auxiliary + ! matrices (for the residuals and refinements). + ! + ! In all formulas below, we need V_k*Sigma_k^(-1) + ! where either V_k is in W(1:N,1:K), or V_k^H is in + ! W(1:K,1:N). Here Sigma_k=diag(WORK(1:K)). + IF ( LSAME(T_OR_N, 'N') ) THEN + DO i = 1, K + CALL ZDSCAL( N, ONE/RWORK(i), W(1,i), 1 ) ! BLAS CALL + ! W(1:N,i) = (ONE/RWORK(i)) * W(1:N,i) ! INTRINSIC + END DO + ELSE + ! This non-unit stride access is due to the fact + ! that ZGESVD, ZGESVDQ and ZGESDD return the + ! adjoint matrix of the right singular vectors. + !DO i = 1, K + ! CALL ZDSCAL( N, ONE/RWORK(i), W(i,1), LDW ) ! BLAS CALL + ! ! W(i,1:N) = (ONE/RWORK(i)) * W(i,1:N) ! INTRINSIC + !END DO + DO i = 1, K + RWORK(N+i) = ONE/RWORK(i) + END DO + DO j = 1, N + DO i = 1, K + W(i,j) = CMPLX(RWORK(N+i),ZERO,KIND=WP)*W(i,j) + END DO + END DO + END IF +! + IF ( WNTREF ) THEN + ! + ! Need A*U(:,1:K)=Y*V_k*inv(diag(WORK(1:K))) + ! for computing the refined Ritz vectors + ! (optionally, outside ZGEDMD). + CALL ZGEMM( 'N', T_OR_N, M, K, N, ZONE, Y, LDY, W, & + LDW, ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),TRANSPOSE(CONJG(W(1:K,1:N)))) ! INTRINSIC, for T_OR_N=='C' + ! Z(1:M,1:K)=MATMUL(Y(1:M,1:N),W(1:N,1:K)) ! INTRINSIC, for T_OR_N=='N' + ! + ! At this point Z contains + ! A * U(:,1:K) = Y * V_k * Sigma_k^(-1), and + ! this is needed for computing the residuals. + ! This matrix is returned in the array B and + ! it can be used to compute refined Ritz vectors. + CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) ! BLAS CALL + ! B(1:M,1:K) = Z(1:M,1:K) ! INTRINSIC + + CALL ZGEMM( 'C', 'N', K, K, M, ZONE, X, LDX, Z, & + LDZ, ZZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(TRANSPOSE(CONJG(X(1:M,1:K))),Z(1:M,1:K)) ! INTRINSIC + ! At this point S = U^H * A * U is the Rayleigh quotient. + ELSE + ! A * U(:,1:K) is not explicitly needed and the + ! computation is organized differently. The Rayleigh + ! quotient is computed more efficiently. + CALL ZGEMM( 'C', 'N', K, N, M, ZONE, X, LDX, Y, LDY, & + ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:K,1:N) = MATMUL( TRANSPOSE(CONJG(X(1:M,1:K))), Y(1:M,1:N) ) ! INTRINSIC + ! + CALL ZGEMM( 'N', T_OR_N, K, K, N, ZONE, Z, LDZ, W, & + LDW, ZZERO, S, LDS ) ! BLAS CALL + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),TRANSPOSE(CONJG(W(1:K,1:N)))) ! INTRINSIC, for T_OR_N=='T' + ! S(1:K,1:K) = MATMUL(Z(1:K,1:N),(W(1:N,1:K))) ! INTRINSIC, for T_OR_N=='N' + ! At this point S = U^H * A * U is the Rayleigh quotient. + ! If the residuals are requested, save scaled V_k into Z. + ! Recall that V_k or V_k^H is stored in W. + IF ( WNTRES .OR. WNTEX ) THEN + IF ( LSAME(T_OR_N, 'N') ) THEN + CALL ZLACPY( 'A', N, K, W, LDW, Z, LDZ ) + ELSE + CALL ZLACPY( 'A', K, N, W, LDW, Z, LDZ ) + END IF + END IF + END IF +! + !<5> Compute the Ritz values and (if requested) the + ! right eigenvectors of the Rayleigh quotient. + ! + CALL ZGEEV( 'N', JOBZL, K, S, LDS, EIGS, W, LDW, & + W, LDW, ZWORK, LZWORK, RWORK(N+1), INFO1 ) ! LAPACK CALL + ! + ! W(1:K,1:K) contains the eigenvectors of the Rayleigh + ! quotient. See the description of Z. + ! Also, see the description of ZGEEV. + IF ( INFO1 > 0 ) THEN + ! ZGEEV failed to compute the eigenvalues and + ! eigenvectors of the Rayleigh quotient. + INFO = 3 + RETURN + END IF +! + ! <6> Compute the eigenvectors (if requested) and, + ! the residuals (if requested). + ! + IF ( WNTVEC .OR. WNTEX ) THEN + IF ( WNTRES ) THEN + IF ( WNTREF ) THEN + ! Here, if the refinement is requested, we have + ! A*U(:,1:K) already computed and stored in Z. + ! For the residuals, need Y = A * U(:,1;K) * W. + CALL ZGEMM( 'N', 'N', M, K, K, ZONE, Z, LDZ, W, & + LDW, ZZERO, Y, LDY ) ! BLAS CALL + ! Y(1:M,1:K) = Z(1:M,1:K) * W(1:K,1:K) ! INTRINSIC + ! This frees Z; Y contains A * U(:,1:K) * W. + ELSE + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) (or its adjoint) is stored in Z + CALL ZGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & + W, LDW, ZZERO, S, LDS ) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + LDS, ZZERO, Z, LDZ ) + ! Save a copy of Z into Y and free Z for holding + ! the Ritz vectors. + CALL ZLACPY( 'A', M, K, Z, LDZ, Y, LDY ) + IF ( WNTEX ) CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF + ELSE IF ( WNTEX ) THEN + ! Compute S = V_k * Sigma_k^(-1) * W, where + ! V_k * Sigma_k^(-1) is stored in Z + CALL ZGEMM( T_OR_N, 'N', N, K, K, ZONE, Z, LDZ, & + W, LDW, ZZERO, S, LDS ) + ! Then, compute Z = Y * S = + ! = Y * V_k * Sigma_k^(-1) * W(1:K,1:K) = + ! = A * U(:,1:K) * W(1:K,1:K) + CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + LDS, ZZERO, B, LDB ) + ! The above call replaces the following two calls + ! that were used in the developing-testing phase. + ! CALL ZGEMM( 'N', 'N', M, K, N, ZONE, Y, LDY, S, & + ! LDS, ZZERO, Z, LDZ) + ! Save a copy of Z into B and free Z for holding + ! the Ritz vectors. + ! CALL ZLACPY( 'A', M, K, Z, LDZ, B, LDB ) + END IF +! + ! Compute the Ritz vectors + IF ( WNTVEC ) CALL ZGEMM( 'N', 'N', M, K, K, ZONE, X, LDX, W, LDW, & + ZZERO, Z, LDZ ) ! BLAS CALL + ! Z(1:M,1:K) = MATMUL(X(1:M,1:K), W(1:K,1:K)) ! INTRINSIC +! + IF ( WNTRES ) THEN + DO i = 1, K + CALL ZAXPY( M, -EIGS(i), Z(1,i), 1, Y(1,i), 1 ) ! BLAS CALL + ! Y(1:M,i) = Y(1:M,i) - EIGS(i) * Z(1:M,i) ! INTRINSIC + RES(i) = DZNRM2( M, Y(1,i), 1 ) ! BLAS CALL + END DO + END IF + END IF +! + IF ( WHTSVD == 4 ) THEN + RWORK(N+1) = XSCL1 + RWORK(N+2) = XSCL2 + END IF +! +! Successful exit. + IF ( .NOT. BADXY ) THEN + INFO = 0 + ELSE + ! A warning on possible data inconsistency. + ! This should be a rare event. + INFO = 4 + END IF +!............................................................ + RETURN +! ...... + END SUBROUTINE ZGEDMD diff --git a/lapack-netlib/SRC/zgejsv.f b/lapack-netlib/SRC/zgejsv.f index b4bc531ab1..b3678af6fe 100644 --- a/lapack-netlib/SRC/zgejsv.f +++ b/lapack-netlib/SRC/zgejsv.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZGEJSV + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -21,9 +19,9 @@ * SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * M, N, A, LDA, SVA, U, LDU, V, LDV, * CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* IMPLICIT NONE * * .. Scalar Arguments .. -* IMPLICIT NONE * INTEGER INFO, LDA, LDU, LDV, LWORK, M, N * .. * .. Array Arguments .. @@ -483,7 +481,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16GEsing +*> \ingroup gejsv * *> \par Further Details: * ===================== @@ -566,13 +564,13 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ M, N, A, LDA, SVA, U, LDU, V, LDV, $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - IMPLICIT NONE INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N * .. * .. Array Arguments .. @@ -596,7 +594,7 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, $ COND_OK, CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, $ MAXPRJ, SCALEM, SCONDA, SFMIN, SMALL, TEMP1, - $ USCAL1, USCAL2, XSC + $ USCAL1, USCAL2, XSC, TBIG INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LQUERY, $ LSVEC, L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, NOSCAL, @@ -623,10 +621,10 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, EXTERNAL IDAMAX, IZAMAX, LSAME, DLAMCH, DZNRM2 * .. * .. External Subroutines .. - EXTERNAL DLASSQ, ZCOPY, ZGELQF, ZGEQP3, ZGEQRF, ZLACPY, ZLAPMR, - $ ZLASCL, DLASCL, ZLASET, ZLASSQ, ZLASWP, ZUNGQR, ZUNMLQ, - $ ZUNMQR, ZPOCON, DSCAL, ZDSCAL, ZSWAP, ZTRSM, ZLACGV, - $ XERBLA + EXTERNAL DLASSQ, ZCOPY, ZGELQF, ZGEQP3, ZGEQRF, ZLACPY, + $ ZLAPMR, ZLASCL, DLASCL, ZLASET, ZLASSQ, ZLASWP, + $ ZUNGQR, ZUNMLQ, ZUNMQR, ZPOCON, DSCAL, ZDSCAL, + $ ZSWAP, ZTRSM, ZLACGV, XERBLA * EXTERNAL ZGESVJ * .. @@ -658,7 +656,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, INFO = - 3 ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN INFO = - 4 - ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. LSAME(JOBT,'N') ) ) THEN + ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. + $ LSAME(JOBT,'N') ) ) THEN INFO = - 5 ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN INFO = - 6 @@ -725,7 +724,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, MINWRK = MAX( N+LWQP3, N+LWQRF, LWSVDJ ) END IF IF ( LQUERY ) THEN - CALL ZGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, V, + CALL ZGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, + $ V, $ LDV, CDUMMY, -1, RDUMMY, -1, IERR ) LWRK_ZGESVJ = INT( CDUMMY(1) ) IF ( ERREST ) THEN @@ -869,7 +869,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ LDU, CDUMMY, -1, IERR ) LWRK_ZUNMQR = INT( CDUMMY(1) ) IF ( .NOT. JRACC ) THEN - CALL ZGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, -1, + CALL ZGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, + $ -1, $ RDUMMY, IERR ) LWRK_ZGEQP3N = INT( CDUMMY(1) ) CALL ZGESVJ( 'L', 'U', 'N', N, N, U, LDU, SVA, @@ -913,10 +914,12 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL ZGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) LWRK_ZGESVJV = INT( CDUMMY(1) ) - CALL ZUNMQR( 'L', 'N', N, N, N, CDUMMY, N, CDUMMY, + CALL ZUNMQR( 'L', 'N', N, N, N, CDUMMY, N, + $ CDUMMY, $ V, LDV, CDUMMY, -1, IERR ) LWRK_ZUNMQR = INT( CDUMMY(1) ) - CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, + $ U, $ LDU, CDUMMY, -1, IERR ) LWRK_ZUNMQRM = INT( CDUMMY(1) ) IF ( ERREST ) THEN @@ -1000,7 +1003,9 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, RETURN END IF AAQQ = SQRT(AAQQ) - IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF ( ( AAPP .LT. TBIG ) .AND. NOSCAL ) THEN SVA(p) = AAPP * AAQQ ELSE NOSCAL = .FALSE. @@ -1064,15 +1069,20 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL ZLACPY( 'A', M, 1, A, LDA, U, LDU ) * computing all M left singular vectors of the M x 1 matrix IF ( N1 .NE. N ) THEN - CALL ZGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) - CALL ZUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) + CALL ZGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N, + $ IERR ) + CALL ZUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N, + $ IERR ) CALL ZCOPY( M, A(1,1), 1, U(1,1), 1 ) END IF END IF IF ( RSVEC ) THEN V(1,1) = CONE END IF - IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + TBIG = BIG + IF ( SCALEM .EQ. ZERO ) SCALEM = ONE + IF ( SCALEM .LT. ONE) TBIG = BIG*SCALEM + IF ( SVA(1) .LT. TBIG ) THEN SVA(1) = SVA(1) / SCALEM SCALEM = ONE END IF @@ -1495,7 +1505,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * * .. second preconditioning using the QR factorization * - CALL ZGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) + CALL ZGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, + $ IERR ) * * .. and transpose upper to lower triangular DO 1948 p = 1, NR - 1 @@ -1522,7 +1533,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 1949 CONTINUE 1947 CONTINUE ELSE - CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), + $ LDA ) END IF * * .. and one-sided Jacobi rotations are started on a lower @@ -1562,7 +1574,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * accumulated product of Jacobi rotations, three are perfect ) * CALL ZLASET( 'L', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) - CALL ZGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) + CALL ZGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, + $ IERR) CALL ZLACPY( 'L', NR, NR, A, LDA, V, LDV ) CALL ZLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) CALL ZGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), @@ -1578,9 +1591,12 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, SCALEM = RWORK(1) NUMRANK = NINT(RWORK(2)) IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) - CALL ZLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) - CALL ZLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) + CALL ZLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), + $ LDV ) + CALL ZLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), + $ LDV ) + CALL ZLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1), + $ LDV ) END IF * CALL ZUNMLQ( 'L', 'C', N, N, NR, A, LDA, CWORK, @@ -1635,10 +1651,13 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, NUMRANK = NINT(RWORK(2)) * IF ( NR .LT. M ) THEN - CALL ZLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) + CALL ZLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), + $ LDU ) IF ( NR .LT. N1 ) THEN - CALL ZLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) - CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) + CALL ZLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1), + $ LDU ) + CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1), + $ LDU ) END IF END IF * @@ -1702,7 +1721,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 2968 CONTINUE 2969 CONTINUE ELSE - CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), + $ LDV ) END IF * * Estimate the row scaled condition number of R1 @@ -1811,7 +1831,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, CALL ZLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) DO 4950 p = 1, NR TEMP1 = DZNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) - CALL ZDSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) + CALL ZDSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), + $ NR ) 4950 CONTINUE CALL ZPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) @@ -1840,7 +1861,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 4969 CONTINUE 4968 CONTINUE ELSE - CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) + CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), + $ LDV ) END IF * * Second preconditioning finished; continue with Jacobi SVD @@ -1868,7 +1890,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * equation is Q2*V2 = the product of the Jacobi rotations * used in ZGESVJ, premultiplied with the orthogonal matrix * from the second QR factorization. - CALL ZTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) + CALL ZTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V, + $ LDV) ELSE * .. R1 is well conditioned, but non-square. Adjoint of R2 * is inverted to get the product of the Jacobi rotations @@ -1879,9 +1902,11 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, IF ( NR .LT. N ) THEN CALL ZLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV) CALL ZLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV) - CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF - CALL ZUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + CALL ZUNMQR('L','N',N,N,NR,CWORK(2*N+1),N, + $ CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) END IF * @@ -1891,7 +1916,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * is Q3^* * V3 = the product of the Jacobi rotations (applied to * the lower triangular L3 from the LQ factorization of * R2=L3*Q3), pre-multiplied with the transposed Q3. - CALL ZGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + CALL ZGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, + $ U, $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, $ RWORK, LRWORK, INFO ) SCALEM = RWORK(1) @@ -1912,9 +1938,12 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, 874 CONTINUE 873 CONTINUE IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1), + $ LDV ) + CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1), + $ LDV ) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) @@ -1930,15 +1959,19 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * defense ensures that ZGEJSV completes the task. * Compute the full SVD of L3 using ZGESVJ with explicit * accumulation of Jacobi rotations. - CALL ZGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + CALL ZGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, + $ U, $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, $ RWORK, LRWORK, INFO ) SCALEM = RWORK(1) NUMRANK = NINT(RWORK(2)) IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1), + $ LDV ) + CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1), + $ LDV ) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1), + $ LDV) END IF CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) @@ -1976,7 +2009,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * At this moment, V contains the right singular vectors of A. * Next, assemble the left singular vector matrix U (M x N). IF ( NR .LT. M ) THEN - CALL ZLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) + CALL ZLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), + $ LDU) IF ( NR .LT. N1 ) THEN CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) CALL ZLASET('A',M-NR,N1-NR,CZERO,CONE, @@ -2050,10 +2084,13 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Assemble the left singular vector matrix U (M x N). * IF ( N .LT. M ) THEN - CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) + CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), + $ LDU ) IF ( N .LT. N1 ) THEN - CALL ZLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) - CALL ZLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) + CALL ZLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1), + $ LDU) + CALL ZLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1), + $ LDU) END IF END IF CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, @@ -2165,10 +2202,13 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Next, assemble the left singular vector matrix U (M x N). * IF ( NR .LT. M ) THEN - CALL ZLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) + CALL ZLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), + $ LDU ) IF ( NR .LT. N1 ) THEN - CALL ZLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) - CALL ZLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) + CALL ZLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1), + $ LDU) + CALL ZLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1), + $ LDU) END IF END IF * @@ -2193,7 +2233,8 @@ SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * Undo scaling, if necessary (and possible) * IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN - CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, + $ IERR ) USCAL1 = ONE USCAL2 = ONE END IF diff --git a/lapack-netlib/SRC/zgesvdx.f b/lapack-netlib/SRC/zgesvdx.f index a8bf560c21..d7ea222b8f 100644 --- a/lapack-netlib/SRC/zgesvdx.f +++ b/lapack-netlib/SRC/zgesvdx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZGESVDX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -261,12 +259,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16GEsing +*> \ingroup gesvdx * * ===================================================================== SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, RWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -305,7 +304,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL ZGEBRD, ZGELQF, ZGEQRF, ZLASCL, ZLASET, ZLACPY, + EXTERNAL ZGEBRD, ZGELQF, ZGEQRF, ZLASCL, ZLASET, + $ ZLACPY, $ ZUNMLQ, ZUNMBR, ZUNMQR, DBDSVDX, DLASCL, XERBLA * .. * .. External Functions .. @@ -394,7 +394,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MAXWRK = 1 IF( MINMN.GT.0 ) THEN IF( M.GE.N ) THEN - MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( M.GE.MNTHR ) THEN * * Path 1 (M much larger than N) @@ -402,24 +403,28 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = N*(N+5) MAXWRK = N + N*ILAENV(1,'ZGEQRF',' ',M,N,-1,-1) MAXWRK = MAX(MAXWRK, - $ N*N+2*N+2*N*ILAENV(1,'ZGEBRD',' ',N,N,-1,-1)) + $ N*N+2*N+2*N*ILAENV(1,'ZGEBRD',' ',N,N,-1, + $ -1)) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, - $ N*N+2*N+N*ILAENV(1,'ZUNMQR','LN',N,N,N,-1)) + $ N*N+2*N+N*ILAENV(1,'ZUNMQR','LN',N,N,N, + $ -1)) END IF ELSE * * Path 2 (M at least N, but not much larger) * MINWRK = 3*N + M - MAXWRK = 2*N + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1) + MAXWRK = 2*N + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1, + $ -1) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, $ 2*N+N*ILAENV(1,'ZUNMQR','LN',N,N,N,-1)) END IF END IF ELSE - MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, + $ 0 ) IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M) @@ -427,10 +432,12 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, MINWRK = M*(M+5) MAXWRK = M + M*ILAENV(1,'ZGELQF',' ',M,N,-1,-1) MAXWRK = MAX(MAXWRK, - $ M*M+2*M+2*M*ILAENV(1,'ZGEBRD',' ',M,M,-1,-1)) + $ M*M+2*M+2*M*ILAENV(1,'ZGEBRD',' ',M,M,-1, + $ -1)) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, - $ M*M+2*M+M*ILAENV(1,'ZUNMQR','LN',M,M,M,-1)) + $ M*M+2*M+M*ILAENV(1,'ZUNMQR','LN',M,M,M, + $ -1)) END IF ELSE * @@ -438,7 +445,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * MINWRK = 3*M + N - MAXWRK = 2*M + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1) + MAXWRK = 2*M + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1, + $ -1) IF (WANTU .OR. WANTVT) THEN MAXWRK = MAX(MAXWRK, $ 2*M+M*ILAENV(1,'ZUNMQR','LN',M,M,M,-1)) @@ -559,7 +567,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) + CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), + $ LDU) * * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -635,7 +644,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) + CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), + $ LDU) * * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) @@ -834,13 +844,14 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Undo scaling if necessary * - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, + IF( ISCL.EQ.1 .AND. NS.GT.0 ) THEN + IF( ANRM.GT.BIGNUM ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, NS, 1, $ S, MINMN, INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, + ELSE IF( ANRM.LT.SMLNUM ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, NS, 1, $ S, MINMN, INFO ) + ENDIF END IF * * Return optimal workspace in WORK(1) diff --git a/lapack-netlib/SRC/zgesvj.f b/lapack-netlib/SRC/zgesvj.f index a8b881e131..6c69f8cf06 100644 --- a/lapack-netlib/SRC/zgesvj.f +++ b/lapack-netlib/SRC/zgesvj.f @@ -381,7 +381,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ BIGTHETA, CS, CTOL, EPSLN, MXAAPQ, $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, THSIGN, - $ TOL + $ TOL, TBIG INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, @@ -458,8 +458,6 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN INFO = -11 - ELSE IF( UCTOL .AND. ( RWORK( 1 ).LT.ONE ) ) THEN - INFO = -12 ELSE IF( LWORK.LT.LWMIN .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 ELSE IF( LRWORK.LT.LRWMIN .AND. ( .NOT.LQUERY ) ) THEN @@ -491,7 +489,12 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( UCTOL ) THEN * ... user controlled - CTOL = RWORK( 1 ) + IF( RWORK( 1 ).LE.ONE ) THEN + INFO = -12 + RETURN + ELSE + CTOL = RWORK( 1 ) + ENDIF ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN @@ -558,7 +561,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT. TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -583,7 +588,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -608,7 +615,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, RETURN END IF AAQQ = SQRT( AAQQ ) - IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN + TBIG = BIG + IF( AAQQ.GT.ONE ) TBIG = BIG / AAQQ + IF( ( AAPP.LT.TBIG ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. @@ -1422,9 +1431,10 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( LSVEC .OR. UCTOL ) THEN DO 1998 p = 1, N4 + TEMP1 = ONE + IF( SVA(p).GT.ZERO ) TEMP1 = SVA(p) * CALL ZDSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) - CALL ZLASCL( 'G',0,0, SVA(p), ONE, M, 1, A(1,p), M, - $ IERR ) + CALL ZLASCL( 'G',0,0, TEMP1, ONE, M, 1, A(1,p), M, IERR ) 1998 CONTINUE END IF * @@ -1438,9 +1448,14 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) - $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. - $ ( SFMIN / SKL ) ) ) ) THEN + NOSCALE = .FALSE. + IF ( SKL.GT.ONE ) THEN + IF( SVA( 1 ).LT.( BIG / SKL ) ) NOSCALE = .TRUE. + ELSE IF( SKL.LT.ONE ) THEN + IF ( SVA( MAX( N2, 1 ) ) .GT. + $ ( SFMIN / SKL ) ) NOSCALE = .TRUE. + ENDIF + IF( NOSCALE ) THEN DO 2400 p = 1, N SVA( p ) = SKL*SVA( p ) 2400 CONTINUE