You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

zgedmdq.f90 31 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689
  1. SUBROUTINE ZGEDMDQ( JOBS, JOBZ, JOBR, JOBQ, JOBT, JOBF, &
  2. WHTSVD, M, N, F, LDF, X, LDX, Y, &
  3. LDY, NRNK, TOL, K, EIGS, &
  4. Z, LDZ, RES, B, LDB, V, LDV, &
  5. S, LDS, ZWORK, LZWORK, WORK, LWORK, &
  6. IWORK, LIWORK, INFO )
  7. ! March 2023
  8. !.....
  9. USE iso_fortran_env
  10. IMPLICIT NONE
  11. INTEGER, PARAMETER :: WP = real64
  12. !.....
  13. ! Scalar arguments
  14. CHARACTER, INTENT(IN) :: JOBS, JOBZ, JOBR, JOBQ, &
  15. JOBT, JOBF
  16. INTEGER, INTENT(IN) :: WHTSVD, M, N, LDF, LDX, &
  17. LDY, NRNK, LDZ, LDB, LDV, &
  18. LDS, LZWORK, LWORK, LIWORK
  19. INTEGER, INTENT(OUT) :: INFO, K
  20. REAL(KIND=WP), INTENT(IN) :: TOL
  21. ! Array arguments
  22. COMPLEX(KIND=WP), INTENT(INOUT) :: F(LDF,*)
  23. COMPLEX(KIND=WP), INTENT(OUT) :: X(LDX,*), Y(LDY,*), &
  24. Z(LDZ,*), B(LDB,*), &
  25. V(LDV,*), S(LDS,*)
  26. COMPLEX(KIND=WP), INTENT(OUT) :: EIGS(*)
  27. COMPLEX(KIND=WP), INTENT(OUT) :: ZWORK(*)
  28. REAL(KIND=WP), INTENT(OUT) :: RES(*)
  29. REAL(KIND=WP), INTENT(OUT) :: WORK(*)
  30. INTEGER, INTENT(OUT) :: IWORK(*)
  31. !.....
  32. ! Purpose
  33. ! =======
  34. ! ZGEDMDQ computes the Dynamic Mode Decomposition (DMD) for
  35. ! a pair of data snapshot matrices, using a QR factorization
  36. ! based compression of the data. For the input matrices
  37. ! X and Y such that Y = A*X with an unaccessible matrix
  38. ! A, ZGEDMDQ computes a certain number of Ritz pairs of A using
  39. ! the standard Rayleigh-Ritz extraction from a subspace of
  40. ! range(X) that is determined using the leading left singular
  41. ! vectors of X. Optionally, ZGEDMDQ returns the residuals
  42. ! of the computed Ritz pairs, the information needed for
  43. ! a refinement of the Ritz vectors, or the eigenvectors of
  44. ! the Exact DMD.
  45. ! For further details see the references listed
  46. ! below. For more details of the implementation see [3].
  47. !
  48. ! References
  49. ! ==========
  50. ! [1] P. Schmid: Dynamic mode decomposition of numerical
  51. ! and experimental data,
  52. ! Journal of Fluid Mechanics 656, 5-28, 2010.
  53. ! [2] Z. Drmac, I. Mezic, R. Mohr: Data driven modal
  54. ! decompositions: analysis and enhancements,
  55. ! SIAM J. on Sci. Comp. 40 (4), A2253-A2285, 2018.
  56. ! [3] Z. Drmac: A LAPACK implementation of the Dynamic
  57. ! Mode Decomposition I. Technical report. AIMDyn Inc.
  58. ! and LAPACK Working Note 298.
  59. ! [4] J. Tu, C. W. Rowley, D. M. Luchtenburg, S. L.
  60. ! Brunton, N. Kutz: On Dynamic Mode Decomposition:
  61. ! Theory and Applications, Journal of Computational
  62. ! Dynamics 1(2), 391 -421, 2014.
  63. !
  64. ! Developed and supported by:
  65. ! ===========================
  66. ! Developed and coded by Zlatko Drmac, Faculty of Science,
  67. ! University of Zagreb; drmac@math.hr
  68. ! In cooperation with
  69. ! AIMdyn Inc., Santa Barbara, CA.
  70. ! and supported by
  71. ! - DARPA SBIR project "Koopman Operator-Based Forecasting
  72. ! for Nonstationary Processes from Near-Term, Limited
  73. ! Observational Data" Contract No: W31P4Q-21-C-0007
  74. ! - DARPA PAI project "Physics-Informed Machine Learning
  75. ! Methodologies" Contract No: HR0011-18-9-0033
  76. ! - DARPA MoDyL project "A Data-Driven, Operator-Theoretic
  77. ! Framework for Space-Time Analysis of Process Dynamics"
  78. ! Contract No: HR0011-16-C-0116
  79. ! Any opinions, findings and conclusions or recommendations
  80. ! expressed in this material are those of the author and
  81. ! do not necessarily reflect the views of the DARPA SBIR
  82. ! Program Office.
  83. !============================================================
  84. ! Distribution Statement A:
  85. ! Approved for Public Release, Distribution Unlimited.
  86. ! Cleared by DARPA on September 29, 2022
  87. !============================================================
  88. !......................................................................
  89. ! Arguments
  90. ! =========
  91. ! JOBS (input) CHARACTER*1
  92. ! Determines whether the initial data snapshots are scaled
  93. ! by a diagonal matrix. The data snapshots are the columns
  94. ! of F. The leading N-1 columns of F are denoted X and the
  95. ! trailing N-1 columns are denoted Y.
  96. ! 'S' :: The data snapshots matrices X and Y are multiplied
  97. ! with a diagonal matrix D so that X*D has unit
  98. ! nonzero columns (in the Euclidean 2-norm)
  99. ! 'C' :: The snapshots are scaled as with the 'S' option.
  100. ! If it is found that an i-th column of X is zero
  101. ! vector and the corresponding i-th column of Y is
  102. ! non-zero, then the i-th column of Y is set to
  103. ! zero and a warning flag is raised.
  104. ! 'Y' :: The data snapshots matrices X and Y are multiplied
  105. ! by a diagonal matrix D so that Y*D has unit
  106. ! nonzero columns (in the Euclidean 2-norm)
  107. ! 'N' :: No data scaling.
  108. !.....
  109. ! JOBZ (input) CHARACTER*1
  110. ! Determines whether the eigenvectors (Koopman modes) will
  111. ! be computed.
  112. ! 'V' :: The eigenvectors (Koopman modes) will be computed
  113. ! and returned in the matrix Z.
  114. ! See the description of Z.
  115. ! 'F' :: The eigenvectors (Koopman modes) will be returned
  116. ! in factored form as the product Z*V, where Z
  117. ! is orthonormal and V contains the eigenvectors
  118. ! of the corresponding Rayleigh quotient.
  119. ! See the descriptions of F, V, Z.
  120. ! 'Q' :: The eigenvectors (Koopman modes) will be returned
  121. ! in factored form as the product Q*Z, where Z
  122. ! contains the eigenvectors of the compression of the
  123. ! underlying discretized operator onto the span of
  124. ! the data snapshots. See the descriptions of F, V, Z.
  125. ! Q is from the initial QR factorization.
  126. ! 'N' :: The eigenvectors are not computed.
  127. !.....
  128. ! JOBR (input) CHARACTER*1
  129. ! Determines whether to compute the residuals.
  130. ! 'R' :: The residuals for the computed eigenpairs will
  131. ! be computed and stored in the array RES.
  132. ! See the description of RES.
  133. ! For this option to be legal, JOBZ must be 'V'.
  134. ! 'N' :: The residuals are not computed.
  135. !.....
  136. ! JOBQ (input) CHARACTER*1
  137. ! Specifies whether to explicitly compute and return the
  138. ! unitary matrix from the QR factorization.
  139. ! 'Q' :: The matrix Q of the QR factorization of the data
  140. ! snapshot matrix is computed and stored in the
  141. ! array F. See the description of F.
  142. ! 'N' :: The matrix Q is not explicitly computed.
  143. !.....
  144. ! JOBT (input) CHARACTER*1
  145. ! Specifies whether to return the upper triangular factor
  146. ! from the QR factorization.
  147. ! 'R' :: The matrix R of the QR factorization of the data
  148. ! snapshot matrix F is returned in the array Y.
  149. ! See the description of Y and Further details.
  150. ! 'N' :: The matrix R is not returned.
  151. !.....
  152. ! JOBF (input) CHARACTER*1
  153. ! Specifies whether to store information needed for post-
  154. ! processing (e.g. computing refined Ritz vectors)
  155. ! 'R' :: The matrix needed for the refinement of the Ritz
  156. ! vectors is computed and stored in the array B.
  157. ! See the description of B.
  158. ! 'E' :: The unscaled eigenvectors of the Exact DMD are
  159. ! computed and returned in the array B. See the
  160. ! description of B.
  161. ! 'N' :: No eigenvector refinement data is computed.
  162. ! To be useful on exit, this option needs JOBQ='Q'.
  163. !.....
  164. ! WHTSVD (input) INTEGER, WHSTVD in { 1, 2, 3, 4 }
  165. ! Allows for a selection of the SVD algorithm from the
  166. ! LAPACK library.
  167. ! 1 :: ZGESVD (the QR SVD algorithm)
  168. ! 2 :: ZGESDD (the Divide and Conquer algorithm; if enough
  169. ! workspace available, this is the fastest option)
  170. ! 3 :: ZGESVDQ (the preconditioned QR SVD ; this and 4
  171. ! are the most accurate options)
  172. ! 4 :: ZGEJSV (the preconditioned Jacobi SVD; this and 3
  173. ! are the most accurate options)
  174. ! For the four methods above, a significant difference in
  175. ! the accuracy of small singular values is possible if
  176. ! the snapshots vary in norm so that X is severely
  177. ! ill-conditioned. If small (smaller than EPS*||X||)
  178. ! singular values are of interest and JOBS=='N', then
  179. ! the options (3, 4) give the most accurate results, where
  180. ! the option 4 is slightly better and with stronger
  181. ! theoretical background.
  182. ! If JOBS=='S', i.e. the columns of X will be normalized,
  183. ! then all methods give nearly equally accurate results.
  184. !.....
  185. ! M (input) INTEGER, M >= 0
  186. ! The state space dimension (the number of rows of F).
  187. !.....
  188. ! N (input) INTEGER, 0 <= N <= M
  189. ! The number of data snapshots from a single trajectory,
  190. ! taken at equidistant discrete times. This is the
  191. ! number of columns of F.
  192. !.....
  193. ! F (input/output) COMPLEX(KIND=WP) M-by-N array
  194. ! > On entry,
  195. ! the columns of F are the sequence of data snapshots
  196. ! from a single trajectory, taken at equidistant discrete
  197. ! times. It is assumed that the column norms of F are
  198. ! in the range of the normalized floating point numbers.
  199. ! < On exit,
  200. ! If JOBQ == 'Q', the array F contains the orthogonal
  201. ! matrix/factor of the QR factorization of the initial
  202. ! data snapshots matrix F. See the description of JOBQ.
  203. ! If JOBQ == 'N', the entries in F strictly below the main
  204. ! diagonal contain, column-wise, the information on the
  205. ! Householder vectors, as returned by ZGEQRF. The
  206. ! remaining information to restore the orthogonal matrix
  207. ! of the initial QR factorization is stored in ZWORK(1:MIN(M,N)).
  208. ! See the description of ZWORK.
  209. !.....
  210. ! LDF (input) INTEGER, LDF >= M
  211. ! The leading dimension of the array F.
  212. !.....
  213. ! X (workspace/output) COMPLEX(KIND=WP) MIN(M,N)-by-(N-1) array
  214. ! X is used as workspace to hold representations of the
  215. ! leading N-1 snapshots in the orthonormal basis computed
  216. ! in the QR factorization of F.
  217. ! On exit, the leading K columns of X contain the leading
  218. ! K left singular vectors of the above described content
  219. ! of X. To lift them to the space of the left singular
  220. ! vectors U(:,1:K) of the input data, pre-multiply with the
  221. ! Q factor from the initial QR factorization.
  222. ! See the descriptions of F, K, V and Z.
  223. !.....
  224. ! LDX (input) INTEGER, LDX >= N
  225. ! The leading dimension of the array X.
  226. !.....
  227. ! Y (workspace/output) COMPLEX(KIND=WP) MIN(M,N)-by-(N) array
  228. ! Y is used as workspace to hold representations of the
  229. ! trailing N-1 snapshots in the orthonormal basis computed
  230. ! in the QR factorization of F.
  231. ! On exit,
  232. ! If JOBT == 'R', Y contains the MIN(M,N)-by-N upper
  233. ! triangular factor from the QR factorization of the data
  234. ! snapshot matrix F.
  235. !.....
  236. ! LDY (input) INTEGER , LDY >= N
  237. ! The leading dimension of the array Y.
  238. !.....
  239. ! NRNK (input) INTEGER
  240. ! Determines the mode how to compute the numerical rank,
  241. ! i.e. how to truncate small singular values of the input
  242. ! matrix X. On input, if
  243. ! NRNK = -1 :: i-th singular value sigma(i) is truncated
  244. ! if sigma(i) <= TOL*sigma(1)
  245. ! This option is recommended.
  246. ! NRNK = -2 :: i-th singular value sigma(i) is truncated
  247. ! if sigma(i) <= TOL*sigma(i-1)
  248. ! This option is included for R&D purposes.
  249. ! It requires highly accurate SVD, which
  250. ! may not be feasible.
  251. ! The numerical rank can be enforced by using positive
  252. ! value of NRNK as follows:
  253. ! 0 < NRNK <= N-1 :: at most NRNK largest singular values
  254. ! will be used. If the number of the computed nonzero
  255. ! singular values is less than NRNK, then only those
  256. ! nonzero values will be used and the actually used
  257. ! dimension is less than NRNK. The actual number of
  258. ! the nonzero singular values is returned in the variable
  259. ! K. See the description of K.
  260. !.....
  261. ! TOL (input) REAL(KIND=WP), 0 <= TOL < 1
  262. ! The tolerance for truncating small singular values.
  263. ! See the description of NRNK.
  264. !.....
  265. ! K (output) INTEGER, 0 <= K <= N
  266. ! The dimension of the SVD/POD basis for the leading N-1
  267. ! data snapshots (columns of F) and the number of the
  268. ! computed Ritz pairs. The value of K is determined
  269. ! according to the rule set by the parameters NRNK and
  270. ! TOL. See the descriptions of NRNK and TOL.
  271. !.....
  272. ! EIGS (output) COMPLEX(KIND=WP) (N-1)-by-1 array
  273. ! The leading K (K<=N-1) entries of EIGS contain
  274. ! the computed eigenvalues (Ritz values).
  275. ! See the descriptions of K, and Z.
  276. !.....
  277. ! Z (workspace/output) COMPLEX(KIND=WP) M-by-(N-1) array
  278. ! If JOBZ =='V' then Z contains the Ritz vectors. Z(:,i)
  279. ! is an eigenvector of the i-th Ritz value; ||Z(:,i)||_2=1.
  280. ! If JOBZ == 'F', then the Z(:,i)'s are given implicitly as
  281. ! Z*V, where Z contains orthonormal matrix (the product of
  282. ! Q from the initial QR factorization and the SVD/POD_basis
  283. ! returned by ZGEDMD in X) and the second factor (the
  284. ! eigenvectors of the Rayleigh quotient) is in the array V,
  285. ! as returned by ZGEDMD. That is, X(:,1:K)*V(:,i)
  286. ! is an eigenvector corresponding to EIGS(i). The columns
  287. ! of V(1:K,1:K) are the computed eigenvectors of the
  288. ! K-by-K Rayleigh quotient.
  289. ! See the descriptions of EIGS, X and V.
  290. !.....
  291. ! LDZ (input) INTEGER , LDZ >= M
  292. ! The leading dimension of the array Z.
  293. !.....
  294. ! RES (output) REAL(KIND=WP) (N-1)-by-1 array
  295. ! RES(1:K) contains the residuals for the K computed
  296. ! Ritz pairs,
  297. ! RES(i) = || A * Z(:,i) - EIGS(i)*Z(:,i))||_2.
  298. ! See the description of EIGS and Z.
  299. !.....
  300. ! B (output) COMPLEX(KIND=WP) MIN(M,N)-by-(N-1) array.
  301. ! IF JOBF =='R', B(1:N,1:K) contains A*U(:,1:K), and can
  302. ! be used for computing the refined vectors; see further
  303. ! details in the provided references.
  304. ! If JOBF == 'E', B(1:N,1;K) contains
  305. ! A*U(:,1:K)*W(1:K,1:K), which are the vectors from the
  306. ! Exact DMD, up to scaling by the inverse eigenvalues.
  307. ! In both cases, the content of B can be lifted to the
  308. ! original dimension of the input data by pre-multiplying
  309. ! with the Q factor from the initial QR factorization.
  310. ! Here A denotes a compression of the underlying operator.
  311. ! See the descriptions of F and X.
  312. ! If JOBF =='N', then B is not referenced.
  313. !.....
  314. ! LDB (input) INTEGER, LDB >= MIN(M,N)
  315. ! The leading dimension of the array B.
  316. !.....
  317. ! V (workspace/output) COMPLEX(KIND=WP) (N-1)-by-(N-1) array
  318. ! On exit, V(1:K,1:K) V contains the K eigenvectors of
  319. ! the Rayleigh quotient. The Ritz vectors
  320. ! (returned in Z) are the product of Q from the initial QR
  321. ! factorization (see the description of F) X (see the
  322. ! description of X) and V.
  323. !.....
  324. ! LDV (input) INTEGER, LDV >= N-1
  325. ! The leading dimension of the array V.
  326. !.....
  327. ! S (output) COMPLEX(KIND=WP) (N-1)-by-(N-1) array
  328. ! The array S(1:K,1:K) is used for the matrix Rayleigh
  329. ! quotient. This content is overwritten during
  330. ! the eigenvalue decomposition by ZGEEV.
  331. ! See the description of K.
  332. !.....
  333. ! LDS (input) INTEGER, LDS >= N-1
  334. ! The leading dimension of the array S.
  335. !.....
  336. ! ZWORK (workspace/output) COMPLEX(KIND=WP) LWORK-by-1 array
  337. ! On exit,
  338. ! ZWORK(1:MIN(M,N)) contains the scalar factors of the
  339. ! elementary reflectors as returned by ZGEQRF of the
  340. ! M-by-N input matrix F.
  341. ! If the call to ZGEDMDQ is only workspace query, then
  342. ! ZWORK(1) contains the minimal complex workspace length and
  343. ! ZWORK(2) is the optimal complex workspace length.
  344. ! Hence, the length of work is at least 2.
  345. ! See the description of LZWORK.
  346. !.....
  347. ! LZWORK (input) INTEGER
  348. ! The minimal length of the workspace vector ZWORK.
  349. ! LZWORK is calculated as follows:
  350. ! Let MLWQR = N (minimal workspace for ZGEQRF[M,N])
  351. ! MLWDMD = minimal workspace for ZGEDMD (see the
  352. ! description of LWORK in ZGEDMD)
  353. ! MLWMQR = N (minimal workspace for
  354. ! ZUNMQR['L','N',M,N,N])
  355. ! MLWGQR = N (minimal workspace for ZUNGQR[M,N,N])
  356. ! MINMN = MIN(M,N)
  357. ! Then
  358. ! LZWORK = MAX(2, MIN(M,N)+MLWQR, MINMN+MLWDMD)
  359. ! is further updated as follows:
  360. ! if JOBZ == 'V' or JOBZ == 'F' THEN
  361. ! LZWORK = MAX(LZWORK, MINMN+MLWMQR)
  362. ! if JOBQ == 'Q' THEN
  363. ! LZWORK = MAX(ZLWORK, MINMN+MLWGQR)
  364. !
  365. !.....
  366. ! WORK (workspace/output) REAL(KIND=WP) LWORK-by-1 array
  367. ! On exit,
  368. ! WORK(1:N-1) contains the singular values of
  369. ! the input submatrix F(1:M,1:N-1).
  370. ! If the call to ZGEDMDQ is only workspace query, then
  371. ! WORK(1) contains the minimal workspace length and
  372. ! WORK(2) is the optimal workspace length. hence, the
  373. ! length of work is at least 2.
  374. ! See the description of LWORK.
  375. !.....
  376. ! LWORK (input) INTEGER
  377. ! The minimal length of the workspace vector WORK.
  378. ! LWORK is the same as in ZGEDMD, because in ZGEDMDQ
  379. ! only ZGEDMD requires real workspace for snapshots
  380. ! of dimensions MIN(M,N)-by-(N-1).
  381. ! If on entry LWORK = -1, then a workspace query is
  382. ! assumed and the procedure only computes the minimal
  383. ! and the optimal workspace length for WORK.
  384. !.....
  385. ! IWORK (workspace/output) INTEGER LIWORK-by-1 array
  386. ! Workspace that is required only if WHTSVD equals
  387. ! 2 , 3 or 4. (See the description of WHTSVD).
  388. ! If on entry LWORK =-1 or LIWORK=-1, then the
  389. ! minimal length of IWORK is computed and returned in
  390. ! IWORK(1). See the description of LIWORK.
  391. !.....
  392. ! LIWORK (input) INTEGER
  393. ! The minimal length of the workspace vector IWORK.
  394. ! If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1
  395. ! Let M1=MIN(M,N), N1=N-1. Then
  396. ! If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M1,N1))
  397. ! If WHTSVD == 3, then LIWORK >= MAX(1,M1+N1-1)
  398. ! If WHTSVD == 4, then LIWORK >= MAX(3,M1+3*N1)
  399. ! If on entry LIWORK = -1, then a workspace query is
  400. ! assumed and the procedure only computes the minimal
  401. ! and the optimal workspace lengths for both WORK and
  402. ! IWORK. See the descriptions of WORK and IWORK.
  403. !.....
  404. ! INFO (output) INTEGER
  405. ! -i < 0 :: On entry, the i-th argument had an
  406. ! illegal value
  407. ! = 0 :: Successful return.
  408. ! = 1 :: Void input. Quick exit (M=0 or N=0).
  409. ! = 2 :: The SVD computation of X did not converge.
  410. ! Suggestion: Check the input data and/or
  411. ! repeat with different WHTSVD.
  412. ! = 3 :: The computation of the eigenvalues did not
  413. ! converge.
  414. ! = 4 :: If data scaling was requested on input and
  415. ! the procedure found inconsistency in the data
  416. ! such that for some column index i,
  417. ! X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set
  418. ! to zero if JOBS=='C'. The computation proceeds
  419. ! with original or modified data and warning
  420. ! flag is set with INFO=4.
  421. !.............................................................
  422. !.............................................................
  423. ! Parameters
  424. ! ~~~~~~~~~~
  425. REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP
  426. REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP
  427. ! COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP )
  428. COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP )
  429. !
  430. ! Local scalars
  431. ! ~~~~~~~~~~~~~
  432. INTEGER :: IMINWR, INFO1, MINMN, MLRWRK, &
  433. MLWDMD, MLWGQR, MLWMQR, MLWORK, &
  434. MLWQR, OLWDMD, OLWGQR, OLWMQR, &
  435. OLWORK, OLWQR
  436. LOGICAL :: LQUERY, SCCOLX, SCCOLY, WANTQ, &
  437. WNTTRF, WNTRES, WNTVEC, WNTVCF, &
  438. WNTVCQ, WNTREF, WNTEX
  439. CHARACTER(LEN=1) :: JOBVL
  440. !
  441. ! External functions (BLAS and LAPACK)
  442. ! ~~~~~~~~~~~~~~~~~
  443. LOGICAL LSAME
  444. EXTERNAL LSAME
  445. !
  446. ! External subroutines (BLAS and LAPACK)
  447. ! ~~~~~~~~~~~~~~~~~~~~
  448. EXTERNAL ZGEQRF, ZLACPY, ZLASET, ZUNGQR, &
  449. ZUNMQR, XERBLA
  450. ! External subroutines
  451. ! ~~~~~~~~~~~~~~~~~~~~
  452. EXTERNAL ZGEDMD
  453. ! Intrinsic functions
  454. ! ~~~~~~~~~~~~~~~~~~~
  455. INTRINSIC MAX, MIN, INT
  456. !..........................................................
  457. !
  458. ! Test the input arguments
  459. WNTRES = LSAME(JOBR,'R')
  460. SCCOLX = LSAME(JOBS,'S') .OR. LSAME( JOBS, 'C' )
  461. SCCOLY = LSAME(JOBS,'Y')
  462. WNTVEC = LSAME(JOBZ,'V')
  463. WNTVCF = LSAME(JOBZ,'F')
  464. WNTVCQ = LSAME(JOBZ,'Q')
  465. WNTREF = LSAME(JOBF,'R')
  466. WNTEX = LSAME(JOBF,'E')
  467. WANTQ = LSAME(JOBQ,'Q')
  468. WNTTRF = LSAME(JOBT,'R')
  469. MINMN = MIN(M,N)
  470. INFO = 0
  471. LQUERY = ( (LZWORK == -1) .OR. (LWORK == -1) .OR. (LIWORK == -1) )
  472. !
  473. IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. &
  474. LSAME(JOBS,'N')) ) THEN
  475. INFO = -1
  476. ELSE IF ( .NOT. (WNTVEC .OR. WNTVCF .OR. WNTVCQ &
  477. .OR. LSAME(JOBZ,'N')) ) THEN
  478. INFO = -2
  479. ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. &
  480. ( WNTRES .AND. LSAME(JOBZ,'N') ) ) THEN
  481. INFO = -3
  482. ELSE IF ( .NOT. (WANTQ .OR. LSAME(JOBQ,'N')) ) THEN
  483. INFO = -4
  484. ELSE IF ( .NOT. ( WNTTRF .OR. LSAME(JOBT,'N') ) ) THEN
  485. INFO = -5
  486. ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. &
  487. LSAME(JOBF,'N') ) ) THEN
  488. INFO = -6
  489. ELSE IF ( .NOT. ((WHTSVD == 1).OR.(WHTSVD == 2).OR. &
  490. (WHTSVD == 3).OR.(WHTSVD == 4)) ) THEN
  491. INFO = -7
  492. ELSE IF ( M < 0 ) THEN
  493. INFO = -8
  494. ELSE IF ( ( N < 0 ) .OR. ( N > M+1 ) ) THEN
  495. INFO = -9
  496. ELSE IF ( LDF < M ) THEN
  497. INFO = -11
  498. ELSE IF ( LDX < MINMN ) THEN
  499. INFO = -13
  500. ELSE IF ( LDY < MINMN ) THEN
  501. INFO = -15
  502. ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. &
  503. ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN
  504. INFO = -16
  505. ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN
  506. INFO = -17
  507. ELSE IF ( LDZ < M ) THEN
  508. INFO = -21
  509. ELSE IF ( (WNTREF.OR.WNTEX ).AND.( LDB < MINMN ) ) THEN
  510. INFO = -24
  511. ELSE IF ( LDV < N-1 ) THEN
  512. INFO = -26
  513. ELSE IF ( LDS < N-1 ) THEN
  514. INFO = -28
  515. END IF
  516. !
  517. IF ( WNTVEC .OR. WNTVCF .OR. WNTVCQ ) THEN
  518. JOBVL = 'V'
  519. ELSE
  520. JOBVL = 'N'
  521. END IF
  522. IF ( INFO == 0 ) THEN
  523. ! Compute the minimal and the optimal workspace
  524. ! requirements. Simulate running the code and
  525. ! determine minimal and optimal sizes of the
  526. ! workspace at any moment of the run.
  527. IF ( ( N == 0 ) .OR. ( N == 1 ) ) THEN
  528. ! All output except K is void. INFO=1 signals
  529. ! the void input. In case of a workspace query,
  530. ! the minimal workspace lengths are returned.
  531. IF ( LQUERY ) THEN
  532. IWORK(1) = 1
  533. ZWORK(1) = 2
  534. ZWORK(2) = 2
  535. WORK(1) = 2
  536. WORK(2) = 2
  537. ELSE
  538. K = 0
  539. END IF
  540. INFO = 1
  541. RETURN
  542. END IF
  543. MLRWRK = 2
  544. MLWORK = 2
  545. OLWORK = 2
  546. IMINWR = 1
  547. MLWQR = MAX(1,N) ! Minimal workspace length for ZGEQRF.
  548. MLWORK = MAX(MLWORK,MINMN + MLWQR)
  549. IF ( LQUERY ) THEN
  550. CALL ZGEQRF( M, N, F, LDF, ZWORK, ZWORK, -1, &
  551. INFO1 )
  552. OLWQR = INT(ZWORK(1))
  553. OLWORK = MAX(OLWORK,MINMN + OLWQR)
  554. END IF
  555. CALL ZGEDMD( JOBS, JOBVL, JOBR, JOBF, WHTSVD, MINMN,&
  556. N-1, X, LDX, Y, LDY, NRNK, TOL, K, &
  557. EIGS, Z, LDZ, RES, B, LDB, V, LDV, &
  558. S, LDS, ZWORK, -1, WORK, -1, IWORK,&
  559. -1, INFO1 )
  560. MLWDMD = INT(ZWORK(1))
  561. MLWORK = MAX(MLWORK, MINMN + MLWDMD)
  562. MLRWRK = MAX(MLRWRK, INT(WORK(1)))
  563. IMINWR = MAX(IMINWR, IWORK(1))
  564. IF ( LQUERY ) THEN
  565. OLWDMD = INT(ZWORK(2))
  566. OLWORK = MAX(OLWORK, MINMN+OLWDMD)
  567. END IF
  568. IF ( WNTVEC .OR. WNTVCF ) THEN
  569. MLWMQR = MAX(1,N)
  570. MLWORK = MAX(MLWORK,MINMN+MLWMQR)
  571. IF ( LQUERY ) THEN
  572. CALL ZUNMQR( 'L','N', M, N, MINMN, F, LDF, &
  573. ZWORK, Z, LDZ, ZWORK, -1, INFO1 )
  574. OLWMQR = INT(ZWORK(1))
  575. OLWORK = MAX(OLWORK,MINMN+OLWMQR)
  576. END IF
  577. END IF
  578. IF ( WANTQ ) THEN
  579. MLWGQR = MAX(1,N)
  580. MLWORK = MAX(MLWORK,MINMN+MLWGQR)
  581. IF ( LQUERY ) THEN
  582. CALL ZUNGQR( M, MINMN, MINMN, F, LDF, ZWORK, &
  583. ZWORK, -1, INFO1 )
  584. OLWGQR = INT(ZWORK(1))
  585. OLWORK = MAX(OLWORK,MINMN+OLWGQR)
  586. END IF
  587. END IF
  588. IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -34
  589. IF ( LWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -32
  590. IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -30
  591. END IF
  592. IF( INFO /= 0 ) THEN
  593. CALL XERBLA( 'ZGEDMDQ', -INFO )
  594. RETURN
  595. ELSE IF ( LQUERY ) THEN
  596. ! Return minimal and optimal workspace sizes
  597. IWORK(1) = IMINWR
  598. ZWORK(1) = MLWORK
  599. ZWORK(2) = OLWORK
  600. WORK(1) = MLRWRK
  601. WORK(2) = MLRWRK
  602. RETURN
  603. END IF
  604. !.....
  605. ! Initial QR factorization that is used to represent the
  606. ! snapshots as elements of lower dimensional subspace.
  607. ! For large scale computation with M >> N, at this place
  608. ! one can use an out of core QRF.
  609. !
  610. CALL ZGEQRF( M, N, F, LDF, ZWORK, &
  611. ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  612. !
  613. ! Define X and Y as the snapshots representations in the
  614. ! orthogonal basis computed in the QR factorization.
  615. ! X corresponds to the leading N-1 and Y to the trailing
  616. ! N-1 snapshots.
  617. CALL ZLASET( 'L', MINMN, N-1, ZZERO, ZZERO, X, LDX )
  618. CALL ZLACPY( 'U', MINMN, N-1, F, LDF, X, LDX )
  619. CALL ZLACPY( 'A', MINMN, N-1, F(1,2), LDF, Y, LDY )
  620. IF ( M >= 3 ) THEN
  621. CALL ZLASET( 'L', MINMN-2, N-2, ZZERO, ZZERO, &
  622. Y(3,1), LDY )
  623. END IF
  624. !
  625. ! Compute the DMD of the projected snapshot pairs (X,Y)
  626. CALL ZGEDMD( JOBS, JOBVL, JOBR, JOBF, WHTSVD, MINMN, &
  627. N-1, X, LDX, Y, LDY, NRNK, TOL, K, &
  628. EIGS, Z, LDZ, RES, B, LDB, V, LDV, &
  629. S, LDS, ZWORK(MINMN+1), LZWORK-MINMN, &
  630. WORK, LWORK, IWORK, LIWORK, INFO1 )
  631. IF ( INFO1 == 2 .OR. INFO1 == 3 ) THEN
  632. ! Return with error code. See ZGEDMD for details.
  633. INFO = INFO1
  634. RETURN
  635. ELSE
  636. INFO = INFO1
  637. END IF
  638. !
  639. ! The Ritz vectors (Koopman modes) can be explicitly
  640. ! formed or returned in factored form.
  641. IF ( WNTVEC ) THEN
  642. ! Compute the eigenvectors explicitly.
  643. IF ( M > MINMN ) CALL ZLASET( 'A', M-MINMN, K, ZZERO, &
  644. ZZERO, Z(MINMN+1,1), LDZ )
  645. CALL ZUNMQR( 'L','N', M, K, MINMN, F, LDF, ZWORK, Z, &
  646. LDZ, ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  647. ELSE IF ( WNTVCF ) THEN
  648. ! Return the Ritz vectors (eigenvectors) in factored
  649. ! form Z*V, where Z contains orthonormal matrix (the
  650. ! product of Q from the initial QR factorization and
  651. ! the SVD/POD_basis returned by ZGEDMD in X) and the
  652. ! second factor (the eigenvectors of the Rayleigh
  653. ! quotient) is in the array V, as returned by ZGEDMD.
  654. CALL ZLACPY( 'A', N, K, X, LDX, Z, LDZ )
  655. IF ( M > N ) CALL ZLASET( 'A', M-N, K, ZZERO, ZZERO, &
  656. Z(N+1,1), LDZ )
  657. CALL ZUNMQR( 'L','N', M, K, MINMN, F, LDF, ZWORK, Z, &
  658. LDZ, ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  659. END IF
  660. !
  661. ! Some optional output variables:
  662. !
  663. ! The upper triangular factor R in the initial QR
  664. ! factorization is optionally returned in the array Y.
  665. ! This is useful if this call to ZGEDMDQ is to be
  666. ! followed by a streaming DMD that is implemented in a
  667. ! QR compressed form.
  668. IF ( WNTTRF ) THEN ! Return the upper triangular R in Y
  669. CALL ZLASET( 'A', MINMN, N, ZZERO, ZZERO, Y, LDY )
  670. CALL ZLACPY( 'U', MINMN, N, F, LDF, Y, LDY )
  671. END IF
  672. !
  673. ! The orthonormal/unitary factor Q in the initial QR
  674. ! factorization is optionally returned in the array F.
  675. ! Same as with the triangular factor above, this is
  676. ! useful in a streaming DMD.
  677. IF ( WANTQ ) THEN ! Q overwrites F
  678. CALL ZUNGQR( M, MINMN, MINMN, F, LDF, ZWORK, &
  679. ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  680. END IF
  681. !
  682. RETURN
  683. !
  684. END SUBROUTINE ZGEDMDQ