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.

cgedmdq.f90 31 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689
  1. SUBROUTINE CGEDMDQ( 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 = real32
  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. ! CGEDMDQ 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, CGEDMDQ 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, CGEDMDQ 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 discretised operator onto the span of
  124. ! the data snapshots. See the descriptions of F, V, Z.
  125. ! Q is from the inital QR facorization.
  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 :: CGESVD (the QR SVD algorithm)
  168. ! 2 :: CGESDD (the Divide and Conquer algorithm; if enough
  169. ! workspace available, this is the fastest option)
  170. ! 3 :: CGESVDQ (the preconditioned QR SVD ; this and 4
  171. ! are the most accurate options)
  172. ! 4 :: CGEJSV (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 CGEQRF. 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 CGEDMD in X) and the second factor (the
  284. ! eigenvectors of the Rayleigh quotient) is in the array V,
  285. ! as returned by CGEDMD. 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 CGEEV.
  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 CGEQRF of the
  340. ! M-by-N input matrix F.
  341. ! If the call to CGEDMDQ 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 CGEQRF[M,N])
  351. ! MLWDMD = minimal workspace for CGEDMD (see the
  352. ! description of LWORK in CGEDMD)
  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 CGEDMDQ 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 CGEDMD, because in CGEDMDQ
  379. ! only CGEDMD 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 lengths for both WORK and
  384. ! IWORK. See the descriptions of WORK and IWORK.
  385. !.....
  386. ! IWORK (workspace/output) INTEGER LIWORK-by-1 array
  387. ! Workspace that is required only if WHTSVD equals
  388. ! 2 , 3 or 4. (See the description of WHTSVD).
  389. ! If on entry LWORK =-1 or LIWORK=-1, then the
  390. ! minimal length of IWORK is computed and returned in
  391. ! IWORK(1). See the description of LIWORK.
  392. !.....
  393. ! LIWORK (input) INTEGER
  394. ! The minimal length of the workspace vector IWORK.
  395. ! If WHTSVD == 1, then only IWORK(1) is used; LIWORK >=1
  396. ! Let M1=MIN(M,N), N1=N-1. Then
  397. ! If WHTSVD == 2, then LIWORK >= MAX(1,8*MIN(M,N))
  398. ! If WHTSVD == 3, then LIWORK >= MAX(1,M+N-1)
  399. ! If WHTSVD == 4, then LIWORK >= MAX(3,M+3*N)
  400. ! If on entry LIWORK = -1, then a workspace query is
  401. ! assumed and the procedure only computes the minimal
  402. ! and the optimal workspace lengths for both WORK and
  403. ! IWORK. See the descriptions of WORK and IWORK.
  404. !.....
  405. ! INFO (output) INTEGER
  406. ! -i < 0 :: On entry, the i-th argument had an
  407. ! illegal value
  408. ! = 0 :: Successful return.
  409. ! = 1 :: Void input. Quick exit (M=0 or N=0).
  410. ! = 2 :: The SVD computation of X did not converge.
  411. ! Suggestion: Check the input data and/or
  412. ! repeat with different WHTSVD.
  413. ! = 3 :: The computation of the eigenvalues did not
  414. ! converge.
  415. ! = 4 :: If data scaling was requested on input and
  416. ! the procedure found inconsistency in the data
  417. ! such that for some column index i,
  418. ! X(:,i) = 0 but Y(:,i) /= 0, then Y(:,i) is set
  419. ! to zero if JOBS=='C'. The computation proceeds
  420. ! with original or modified data and warning
  421. ! flag is set with INFO=4.
  422. !.............................................................
  423. !.............................................................
  424. ! Parameters
  425. ! ~~~~~~~~~~
  426. REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP
  427. REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP
  428. ! COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP )
  429. COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP )
  430. !
  431. ! Local scalars
  432. ! ~~~~~~~~~~~~~
  433. INTEGER :: IMINWR, INFO1, MINMN, MLRWRK, &
  434. MLWDMD, MLWGQR, MLWMQR, MLWORK, &
  435. MLWQR, OLWDMD, OLWGQR, OLWMQR, &
  436. OLWORK, OLWQR
  437. LOGICAL :: LQUERY, SCCOLX, SCCOLY, WANTQ, &
  438. WNTTRF, WNTRES, WNTVEC, WNTVCF, &
  439. WNTVCQ, WNTREF, WNTEX
  440. CHARACTER(LEN=1) :: JOBVL
  441. !
  442. ! External functions (BLAS and LAPACK)
  443. ! ~~~~~~~~~~~~~~~~~
  444. LOGICAL LSAME
  445. EXTERNAL LSAME
  446. !
  447. ! External subroutines (BLAS and LAPACK)
  448. ! ~~~~~~~~~~~~~~~~~~~~
  449. EXTERNAL CGEQRF, CLACPY, CLASET, CUNGQR, &
  450. CUNMQR, XERBLA
  451. ! External subroutines
  452. ! ~~~~~~~~~~~~~~~~~~~~
  453. EXTERNAL CGEDMD
  454. ! Intrinsic functions
  455. ! ~~~~~~~~~~~~~~~~~~~
  456. INTRINSIC MAX, MIN, INT
  457. !..........................................................
  458. !
  459. ! Test the input arguments
  460. WNTRES = LSAME(JOBR,'R')
  461. SCCOLX = LSAME(JOBS,'S') .OR. LSAME( JOBS, 'C' )
  462. SCCOLY = LSAME(JOBS,'Y')
  463. WNTVEC = LSAME(JOBZ,'V')
  464. WNTVCF = LSAME(JOBZ,'F')
  465. WNTVCQ = LSAME(JOBZ,'Q')
  466. WNTREF = LSAME(JOBF,'R')
  467. WNTEX = LSAME(JOBF,'E')
  468. WANTQ = LSAME(JOBQ,'Q')
  469. WNTTRF = LSAME(JOBT,'R')
  470. MINMN = MIN(M,N)
  471. INFO = 0
  472. LQUERY = ( ( LWORK == -1 ) .OR. ( LIWORK == -1 ) )
  473. !
  474. IF ( .NOT. (SCCOLX .OR. SCCOLY .OR. &
  475. LSAME(JOBS,'N')) ) THEN
  476. INFO = -1
  477. ELSE IF ( .NOT. (WNTVEC .OR. WNTVCF .OR. WNTVCQ &
  478. .OR. LSAME(JOBZ,'N')) ) THEN
  479. INFO = -2
  480. ELSE IF ( .NOT. (WNTRES .OR. LSAME(JOBR,'N')) .OR. &
  481. ( WNTRES .AND. LSAME(JOBZ,'N') ) ) THEN
  482. INFO = -3
  483. ELSE IF ( .NOT. (WANTQ .OR. LSAME(JOBQ,'N')) ) THEN
  484. INFO = -4
  485. ELSE IF ( .NOT. ( WNTTRF .OR. LSAME(JOBT,'N') ) ) THEN
  486. INFO = -5
  487. ELSE IF ( .NOT. (WNTREF .OR. WNTEX .OR. &
  488. LSAME(JOBF,'N') ) ) THEN
  489. INFO = -6
  490. ELSE IF ( .NOT. ((WHTSVD == 1).OR.(WHTSVD == 2).OR. &
  491. (WHTSVD == 3).OR.(WHTSVD == 4)) ) THEN
  492. INFO = -7
  493. ELSE IF ( M < 0 ) THEN
  494. INFO = -8
  495. ELSE IF ( ( N < 0 ) .OR. ( N > M+1 ) ) THEN
  496. INFO = -9
  497. ELSE IF ( LDF < M ) THEN
  498. INFO = -11
  499. ELSE IF ( LDX < MINMN ) THEN
  500. INFO = -13
  501. ELSE IF ( LDY < MINMN ) THEN
  502. INFO = -15
  503. ELSE IF ( .NOT. (( NRNK == -2).OR.(NRNK == -1).OR. &
  504. ((NRNK >= 1).AND.(NRNK <=N ))) ) THEN
  505. INFO = -16
  506. ELSE IF ( ( TOL < ZERO ) .OR. ( TOL >= ONE ) ) THEN
  507. INFO = -17
  508. ELSE IF ( LDZ < M ) THEN
  509. INFO = -21
  510. ELSE IF ( (WNTREF.OR.WNTEX ).AND.( LDB < MINMN ) ) THEN
  511. INFO = -24
  512. ELSE IF ( LDV < N-1 ) THEN
  513. INFO = -26
  514. ELSE IF ( LDS < N-1 ) THEN
  515. INFO = -28
  516. END IF
  517. !
  518. IF ( WNTVEC .OR. WNTVCF .OR. WNTVCQ ) THEN
  519. JOBVL = 'V'
  520. ELSE
  521. JOBVL = 'N'
  522. END IF
  523. IF ( INFO == 0 ) THEN
  524. ! Compute the minimal and the optimal workspace
  525. ! requirements. Simulate running the code and
  526. ! determine minimal and optimal sizes of the
  527. ! workspace at any moment of the run.
  528. IF ( ( N == 0 ) .OR. ( N == 1 ) ) THEN
  529. ! All output except K is void. INFO=1 signals
  530. ! the void input. In case of a workspace query,
  531. ! the minimal workspace lengths are returned.
  532. IF ( LQUERY ) THEN
  533. IWORK(1) = 1
  534. WORK(1) = 2
  535. WORK(2) = 2
  536. ELSE
  537. K = 0
  538. END IF
  539. INFO = 1
  540. RETURN
  541. END IF
  542. MLRWRK = 2
  543. MLWORK = 2
  544. OLWORK = 2
  545. IMINWR = 1
  546. MLWQR = MAX(1,N) ! Minimal workspace length for CGEQRF.
  547. MLWORK = MAX(MLWORK,MINMN + MLWQR)
  548. IF ( LQUERY ) THEN
  549. CALL CGEQRF( M, N, F, LDF, ZWORK, ZWORK, -1, &
  550. INFO1 )
  551. OLWQR = INT(ZWORK(1))
  552. OLWORK = MAX(OLWORK,MINMN + OLWQR)
  553. END IF
  554. CALL CGEDMD( JOBS, JOBVL, JOBR, JOBF, WHTSVD, MINMN,&
  555. N-1, X, LDX, Y, LDY, NRNK, TOL, K, &
  556. EIGS, Z, LDZ, RES, B, LDB, V, LDV, &
  557. S, LDS, ZWORK, LZWORK, WORK, -1, IWORK,&
  558. LIWORK, INFO1 )
  559. MLWDMD = INT(ZWORK(1))
  560. MLWORK = MAX(MLWORK, MINMN + MLWDMD)
  561. MLRWRK = MAX(MLRWRK, INT(WORK(1)))
  562. IMINWR = MAX(IMINWR, IWORK(1))
  563. IF ( LQUERY ) THEN
  564. OLWDMD = INT(ZWORK(2))
  565. OLWORK = MAX(OLWORK, MINMN+OLWDMD)
  566. END IF
  567. IF ( WNTVEC .OR. WNTVCF ) THEN
  568. MLWMQR = MAX(1,N)
  569. MLWORK = MAX(MLWORK, MINMN+MLWMQR)
  570. IF ( LQUERY ) THEN
  571. CALL CUNMQR( 'L','N', M, N, MINMN, F, LDF, &
  572. ZWORK, Z, LDZ, ZWORK, -1, INFO1 )
  573. OLWMQR = INT(ZWORK(1))
  574. OLWORK = MAX(OLWORK, MINMN+OLWMQR)
  575. END IF
  576. END IF
  577. IF ( WANTQ ) THEN
  578. MLWGQR = MAX(1,N)
  579. MLWORK = MAX(MLWORK, MINMN+MLWGQR)
  580. IF ( LQUERY ) THEN
  581. CALL CUNGQR( M, MINMN, MINMN, F, LDF, ZWORK, &
  582. ZWORK, -1, INFO1 )
  583. OLWGQR = INT(ZWORK(1))
  584. OLWORK = MAX(OLWORK, MINMN+OLWGQR)
  585. END IF
  586. END IF
  587. IF ( LIWORK < IMINWR .AND. (.NOT.LQUERY) ) INFO = -34
  588. IF ( LWORK < MLRWRK .AND. (.NOT.LQUERY) ) INFO = -32
  589. IF ( LZWORK < MLWORK .AND. (.NOT.LQUERY) ) INFO = -30
  590. END IF
  591. IF( INFO /= 0 ) THEN
  592. CALL XERBLA( 'CGEDMDQ', -INFO )
  593. RETURN
  594. ELSE IF ( LQUERY ) THEN
  595. ! Return minimal and optimal workspace sizes
  596. IWORK(1) = IMINWR
  597. ZWORK(1) = MLWORK
  598. ZWORK(2) = OLWORK
  599. WORK(1) = MLRWRK
  600. WORK(2) = MLRWRK
  601. RETURN
  602. END IF
  603. !.....
  604. ! Initial QR factorization that is used to represent the
  605. ! snapshots as elements of lower dimensional subspace.
  606. ! For large scale computation with M >>N , at this place
  607. ! one can use an out of core QRF.
  608. !
  609. CALL CGEQRF( M, N, F, LDF, ZWORK, &
  610. ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  611. !
  612. ! Define X and Y as the snapshots representations in the
  613. ! orthogonal basis computed in the QR factorization.
  614. ! X corresponds to the leading N-1 and Y to the trailing
  615. ! N-1 snapshots.
  616. CALL CLASET( 'L', MINMN, N-1, ZZERO, ZZERO, X, LDX )
  617. CALL CLACPY( 'U', MINMN, N-1, F, LDF, X, LDX )
  618. CALL CLACPY( 'A', MINMN, N-1, F(1,2), LDF, Y, LDY )
  619. IF ( M >= 3 ) THEN
  620. CALL CLASET( 'L', MINMN-2, N-2, ZZERO, ZZERO, &
  621. Y(3,1), LDY )
  622. END IF
  623. !
  624. ! Compute the DMD of the projected snapshot pairs (X,Y)
  625. CALL CGEDMD( JOBS, JOBVL, JOBR, JOBF, WHTSVD, MINMN, &
  626. N-1, X, LDX, Y, LDY, NRNK, TOL, K, &
  627. EIGS, Z, LDZ, RES, B, LDB, V, LDV, &
  628. S, LDS, ZWORK(MINMN+1), LZWORK-MINMN, &
  629. WORK, LWORK, IWORK, LIWORK, INFO1 )
  630. IF ( INFO1 == 2 .OR. INFO1 == 3 ) THEN
  631. ! Return with error code. See CGEDMD for details.
  632. INFO = INFO1
  633. RETURN
  634. ELSE
  635. INFO = INFO1
  636. END IF
  637. !
  638. ! The Ritz vectors (Koopman modes) can be explicitly
  639. ! formed or returned in factored form.
  640. IF ( WNTVEC ) THEN
  641. ! Compute the eigenvectors explicitly.
  642. IF ( M > MINMN ) CALL CLASET( 'A', M-MINMN, K, ZZERO, &
  643. ZZERO, Z(MINMN+1,1), LDZ )
  644. CALL CUNMQR( 'L','N', M, K, MINMN, F, LDF, ZWORK, Z, &
  645. LDZ, ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  646. ELSE IF ( WNTVCF ) THEN
  647. ! Return the Ritz vectors (eigenvectors) in factored
  648. ! form Z*V, where Z contains orthonormal matrix (the
  649. ! product of Q from the initial QR factorization and
  650. ! the SVD/POD_basis returned by CGEDMD in X) and the
  651. ! second factor (the eigenvectors of the Rayleigh
  652. ! quotient) is in the array V, as returned by CGEDMD.
  653. CALL CLACPY( 'A', N, K, X, LDX, Z, LDZ )
  654. IF ( M > N ) CALL CLASET( 'A', M-N, K, ZZERO, ZZERO, &
  655. Z(N+1,1), LDZ )
  656. CALL CUNMQR( 'L','N', M, K, MINMN, F, LDF, ZWORK, Z, &
  657. LDZ, ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  658. END IF
  659. !
  660. ! Some optional output variables:
  661. !
  662. ! The upper triangular factor R in the initial QR
  663. ! factorization is optionally returned in the array Y.
  664. ! This is useful if this call to CGEDMDQ is to be
  665. ! followed by a streaming DMD that is implemented in a
  666. ! QR compressed form.
  667. IF ( WNTTRF ) THEN ! Return the upper triangular R in Y
  668. CALL CLASET( 'A', MINMN, N, ZZERO, ZZERO, Y, LDY )
  669. CALL CLACPY( 'U', MINMN, N, F, LDF, Y, LDY )
  670. END IF
  671. !
  672. ! The orthonormal/unitary factor Q in the initial QR
  673. ! factorization is optionally returned in the array F.
  674. ! Same as with the triangular factor above, this is
  675. ! useful in a streaming DMD.
  676. IF ( WANTQ ) THEN ! Q overwrites F
  677. CALL CUNGQR( M, MINMN, MINMN, F, LDF, ZWORK, &
  678. ZWORK(MINMN+1), LZWORK-MINMN, INFO1 )
  679. END IF
  680. !
  681. RETURN
  682. !
  683. END SUBROUTINE CGEDMDQ