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.

cgesvd.f 143 kB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703
  1. *> \brief <b> CGESVD computes the singular value decomposition (SVD) for GE matrices</b>
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download CGESVD + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgesvd.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgesvd.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgesvd.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
  22. * WORK, LWORK, RWORK, INFO )
  23. *
  24. * .. Scalar Arguments ..
  25. * CHARACTER JOBU, JOBVT
  26. * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
  27. * ..
  28. * .. Array Arguments ..
  29. * REAL RWORK( * ), S( * )
  30. * COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
  31. * $ WORK( * )
  32. * ..
  33. *
  34. *
  35. *> \par Purpose:
  36. * =============
  37. *>
  38. *> \verbatim
  39. *>
  40. *> CGESVD computes the singular value decomposition (SVD) of a complex
  41. *> M-by-N matrix A, optionally computing the left and/or right singular
  42. *> vectors. The SVD is written
  43. *>
  44. *> A = U * SIGMA * conjugate-transpose(V)
  45. *>
  46. *> where SIGMA is an M-by-N matrix which is zero except for its
  47. *> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
  48. *> V is an N-by-N unitary matrix. The diagonal elements of SIGMA
  49. *> are the singular values of A; they are real and non-negative, and
  50. *> are returned in descending order. The first min(m,n) columns of
  51. *> U and V are the left and right singular vectors of A.
  52. *>
  53. *> Note that the routine returns V**H, not V.
  54. *> \endverbatim
  55. *
  56. * Arguments:
  57. * ==========
  58. *
  59. *> \param[in] JOBU
  60. *> \verbatim
  61. *> JOBU is CHARACTER*1
  62. *> Specifies options for computing all or part of the matrix U:
  63. *> = 'A': all M columns of U are returned in array U:
  64. *> = 'S': the first min(m,n) columns of U (the left singular
  65. *> vectors) are returned in the array U;
  66. *> = 'O': the first min(m,n) columns of U (the left singular
  67. *> vectors) are overwritten on the array A;
  68. *> = 'N': no columns of U (no left singular vectors) are
  69. *> computed.
  70. *> \endverbatim
  71. *>
  72. *> \param[in] JOBVT
  73. *> \verbatim
  74. *> JOBVT is CHARACTER*1
  75. *> Specifies options for computing all or part of the matrix
  76. *> V**H:
  77. *> = 'A': all N rows of V**H are returned in the array VT;
  78. *> = 'S': the first min(m,n) rows of V**H (the right singular
  79. *> vectors) are returned in the array VT;
  80. *> = 'O': the first min(m,n) rows of V**H (the right singular
  81. *> vectors) are overwritten on the array A;
  82. *> = 'N': no rows of V**H (no right singular vectors) are
  83. *> computed.
  84. *>
  85. *> JOBVT and JOBU cannot both be 'O'.
  86. *> \endverbatim
  87. *>
  88. *> \param[in] M
  89. *> \verbatim
  90. *> M is INTEGER
  91. *> The number of rows of the input matrix A. M >= 0.
  92. *> \endverbatim
  93. *>
  94. *> \param[in] N
  95. *> \verbatim
  96. *> N is INTEGER
  97. *> The number of columns of the input matrix A. N >= 0.
  98. *> \endverbatim
  99. *>
  100. *> \param[in,out] A
  101. *> \verbatim
  102. *> A is COMPLEX array, dimension (LDA,N)
  103. *> On entry, the M-by-N matrix A.
  104. *> On exit,
  105. *> if JOBU = 'O', A is overwritten with the first min(m,n)
  106. *> columns of U (the left singular vectors,
  107. *> stored columnwise);
  108. *> if JOBVT = 'O', A is overwritten with the first min(m,n)
  109. *> rows of V**H (the right singular vectors,
  110. *> stored rowwise);
  111. *> if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
  112. *> are destroyed.
  113. *> \endverbatim
  114. *>
  115. *> \param[in] LDA
  116. *> \verbatim
  117. *> LDA is INTEGER
  118. *> The leading dimension of the array A. LDA >= max(1,M).
  119. *> \endverbatim
  120. *>
  121. *> \param[out] S
  122. *> \verbatim
  123. *> S is REAL array, dimension (min(M,N))
  124. *> The singular values of A, sorted so that S(i) >= S(i+1).
  125. *> \endverbatim
  126. *>
  127. *> \param[out] U
  128. *> \verbatim
  129. *> U is COMPLEX array, dimension (LDU,UCOL)
  130. *> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
  131. *> If JOBU = 'A', U contains the M-by-M unitary matrix U;
  132. *> if JOBU = 'S', U contains the first min(m,n) columns of U
  133. *> (the left singular vectors, stored columnwise);
  134. *> if JOBU = 'N' or 'O', U is not referenced.
  135. *> \endverbatim
  136. *>
  137. *> \param[in] LDU
  138. *> \verbatim
  139. *> LDU is INTEGER
  140. *> The leading dimension of the array U. LDU >= 1; if
  141. *> JOBU = 'S' or 'A', LDU >= M.
  142. *> \endverbatim
  143. *>
  144. *> \param[out] VT
  145. *> \verbatim
  146. *> VT is COMPLEX array, dimension (LDVT,N)
  147. *> If JOBVT = 'A', VT contains the N-by-N unitary matrix
  148. *> V**H;
  149. *> if JOBVT = 'S', VT contains the first min(m,n) rows of
  150. *> V**H (the right singular vectors, stored rowwise);
  151. *> if JOBVT = 'N' or 'O', VT is not referenced.
  152. *> \endverbatim
  153. *>
  154. *> \param[in] LDVT
  155. *> \verbatim
  156. *> LDVT is INTEGER
  157. *> The leading dimension of the array VT. LDVT >= 1; if
  158. *> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
  159. *> \endverbatim
  160. *>
  161. *> \param[out] WORK
  162. *> \verbatim
  163. *> WORK is COMPLEX array, dimension (MAX(1,LWORK))
  164. *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
  165. *> \endverbatim
  166. *>
  167. *> \param[in] LWORK
  168. *> \verbatim
  169. *> LWORK is INTEGER
  170. *> The dimension of the array WORK.
  171. *> LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).
  172. *> For good performance, LWORK should generally be larger.
  173. *>
  174. *> If LWORK = -1, then a workspace query is assumed; the routine
  175. *> only calculates the optimal size of the WORK array, returns
  176. *> this value as the first entry of the WORK array, and no error
  177. *> message related to LWORK is issued by XERBLA.
  178. *> \endverbatim
  179. *>
  180. *> \param[out] RWORK
  181. *> \verbatim
  182. *> RWORK is REAL array, dimension (5*min(M,N))
  183. *> On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
  184. *> unconverged superdiagonal elements of an upper bidiagonal
  185. *> matrix B whose diagonal is in S (not necessarily sorted).
  186. *> B satisfies A = U * B * VT, so it has the same singular
  187. *> values as A, and singular vectors related by U and VT.
  188. *> \endverbatim
  189. *>
  190. *> \param[out] INFO
  191. *> \verbatim
  192. *> INFO is INTEGER
  193. *> = 0: successful exit.
  194. *> < 0: if INFO = -i, the i-th argument had an illegal value.
  195. *> > 0: if CBDSQR did not converge, INFO specifies how many
  196. *> superdiagonals of an intermediate bidiagonal form B
  197. *> did not converge to zero. See the description of RWORK
  198. *> above for details.
  199. *> \endverbatim
  200. *
  201. * Authors:
  202. * ========
  203. *
  204. *> \author Univ. of Tennessee
  205. *> \author Univ. of California Berkeley
  206. *> \author Univ. of Colorado Denver
  207. *> \author NAG Ltd.
  208. *
  209. *> \ingroup complexGEsing
  210. *
  211. * =====================================================================
  212. SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
  213. $ WORK, LWORK, RWORK, INFO )
  214. *
  215. * -- LAPACK driver routine --
  216. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  217. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  218. *
  219. * .. Scalar Arguments ..
  220. CHARACTER JOBU, JOBVT
  221. INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
  222. * ..
  223. * .. Array Arguments ..
  224. REAL RWORK( * ), S( * )
  225. COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
  226. $ WORK( * )
  227. * ..
  228. *
  229. * =====================================================================
  230. *
  231. * .. Parameters ..
  232. COMPLEX CZERO, CONE
  233. PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ),
  234. $ CONE = ( 1.0E0, 0.0E0 ) )
  235. REAL ZERO, ONE
  236. PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
  237. * ..
  238. * .. Local Scalars ..
  239. LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
  240. $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
  241. INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
  242. $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
  243. $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
  244. $ NRVT, WRKBL
  245. INTEGER LWORK_CGEQRF, LWORK_CUNGQR_N, LWORK_CUNGQR_M,
  246. $ LWORK_CGEBRD, LWORK_CUNGBR_P, LWORK_CUNGBR_Q,
  247. $ LWORK_CGELQF, LWORK_CUNGLQ_N, LWORK_CUNGLQ_M
  248. REAL ANRM, BIGNUM, EPS, SMLNUM
  249. * ..
  250. * .. Local Arrays ..
  251. REAL DUM( 1 )
  252. COMPLEX CDUM( 1 )
  253. * ..
  254. * .. External Subroutines ..
  255. EXTERNAL CBDSQR, CGEBRD, CGELQF, CGEMM, CGEQRF, CLACPY,
  256. $ CLASCL, CLASET, CUNGBR, CUNGLQ, CUNGQR, CUNMBR,
  257. $ SLASCL, XERBLA
  258. * ..
  259. * .. External Functions ..
  260. LOGICAL LSAME
  261. INTEGER ILAENV
  262. REAL CLANGE, SLAMCH
  263. EXTERNAL LSAME, ILAENV, CLANGE, SLAMCH
  264. * ..
  265. * .. Intrinsic Functions ..
  266. INTRINSIC MAX, MIN, SQRT
  267. * ..
  268. * .. Executable Statements ..
  269. *
  270. * Test the input arguments
  271. *
  272. INFO = 0
  273. MINMN = MIN( M, N )
  274. WNTUA = LSAME( JOBU, 'A' )
  275. WNTUS = LSAME( JOBU, 'S' )
  276. WNTUAS = WNTUA .OR. WNTUS
  277. WNTUO = LSAME( JOBU, 'O' )
  278. WNTUN = LSAME( JOBU, 'N' )
  279. WNTVA = LSAME( JOBVT, 'A' )
  280. WNTVS = LSAME( JOBVT, 'S' )
  281. WNTVAS = WNTVA .OR. WNTVS
  282. WNTVO = LSAME( JOBVT, 'O' )
  283. WNTVN = LSAME( JOBVT, 'N' )
  284. LQUERY = ( LWORK.EQ.-1 )
  285. *
  286. IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
  287. INFO = -1
  288. ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
  289. $ ( WNTVO .AND. WNTUO ) ) THEN
  290. INFO = -2
  291. ELSE IF( M.LT.0 ) THEN
  292. INFO = -3
  293. ELSE IF( N.LT.0 ) THEN
  294. INFO = -4
  295. ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
  296. INFO = -6
  297. ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
  298. INFO = -9
  299. ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
  300. $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
  301. INFO = -11
  302. END IF
  303. *
  304. * Compute workspace
  305. * (Note: Comments in the code beginning "Workspace:" describe the
  306. * minimal amount of workspace needed at that point in the code,
  307. * as well as the preferred amount for good performance.
  308. * CWorkspace refers to complex workspace, and RWorkspace to
  309. * real workspace. NB refers to the optimal block size for the
  310. * immediately following subroutine, as returned by ILAENV.)
  311. *
  312. IF( INFO.EQ.0 ) THEN
  313. MINWRK = 1
  314. MAXWRK = 1
  315. IF( M.GE.N .AND. MINMN.GT.0 ) THEN
  316. *
  317. * Space needed for ZBDSQR is BDSPAC = 5*N
  318. *
  319. MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 )
  320. * Compute space needed for CGEQRF
  321. CALL CGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
  322. LWORK_CGEQRF = INT( CDUM(1) )
  323. * Compute space needed for CUNGQR
  324. CALL CUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
  325. LWORK_CUNGQR_N = INT( CDUM(1) )
  326. CALL CUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
  327. LWORK_CUNGQR_M = INT( CDUM(1) )
  328. * Compute space needed for CGEBRD
  329. CALL CGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1),
  330. $ CDUM(1), CDUM(1), -1, IERR )
  331. LWORK_CGEBRD = INT( CDUM(1) )
  332. * Compute space needed for CUNGBR
  333. CALL CUNGBR( 'P', N, N, N, A, LDA, CDUM(1),
  334. $ CDUM(1), -1, IERR )
  335. LWORK_CUNGBR_P = INT( CDUM(1) )
  336. CALL CUNGBR( 'Q', N, N, N, A, LDA, CDUM(1),
  337. $ CDUM(1), -1, IERR )
  338. LWORK_CUNGBR_Q = INT( CDUM(1) )
  339. *
  340. MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 )
  341. IF( M.GE.MNTHR ) THEN
  342. IF( WNTUN ) THEN
  343. *
  344. * Path 1 (M much larger than N, JOBU='N')
  345. *
  346. MAXWRK = N + LWORK_CGEQRF
  347. MAXWRK = MAX( MAXWRK, 2*N+LWORK_CGEBRD )
  348. IF( WNTVO .OR. WNTVAS )
  349. $ MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_P )
  350. MINWRK = 3*N
  351. ELSE IF( WNTUO .AND. WNTVN ) THEN
  352. *
  353. * Path 2 (M much larger than N, JOBU='O', JOBVT='N')
  354. *
  355. WRKBL = N + LWORK_CGEQRF
  356. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_N )
  357. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  358. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  359. MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
  360. MINWRK = 2*N + M
  361. ELSE IF( WNTUO .AND. WNTVAS ) THEN
  362. *
  363. * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
  364. * 'A')
  365. *
  366. WRKBL = N + LWORK_CGEQRF
  367. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_N )
  368. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  369. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  370. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_P )
  371. MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
  372. MINWRK = 2*N + M
  373. ELSE IF( WNTUS .AND. WNTVN ) THEN
  374. *
  375. * Path 4 (M much larger than N, JOBU='S', JOBVT='N')
  376. *
  377. WRKBL = N + LWORK_CGEQRF
  378. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_N )
  379. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  380. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  381. MAXWRK = N*N + WRKBL
  382. MINWRK = 2*N + M
  383. ELSE IF( WNTUS .AND. WNTVO ) THEN
  384. *
  385. * Path 5 (M much larger than N, JOBU='S', JOBVT='O')
  386. *
  387. WRKBL = N + LWORK_CGEQRF
  388. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_N )
  389. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  390. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  391. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_P )
  392. MAXWRK = 2*N*N + WRKBL
  393. MINWRK = 2*N + M
  394. ELSE IF( WNTUS .AND. WNTVAS ) THEN
  395. *
  396. * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
  397. * 'A')
  398. *
  399. WRKBL = N + LWORK_CGEQRF
  400. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_N )
  401. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  402. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  403. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_P )
  404. MAXWRK = N*N + WRKBL
  405. MINWRK = 2*N + M
  406. ELSE IF( WNTUA .AND. WNTVN ) THEN
  407. *
  408. * Path 7 (M much larger than N, JOBU='A', JOBVT='N')
  409. *
  410. WRKBL = N + LWORK_CGEQRF
  411. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_M )
  412. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  413. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  414. MAXWRK = N*N + WRKBL
  415. MINWRK = 2*N + M
  416. ELSE IF( WNTUA .AND. WNTVO ) THEN
  417. *
  418. * Path 8 (M much larger than N, JOBU='A', JOBVT='O')
  419. *
  420. WRKBL = N + LWORK_CGEQRF
  421. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_M )
  422. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  423. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  424. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_P )
  425. MAXWRK = 2*N*N + WRKBL
  426. MINWRK = 2*N + M
  427. ELSE IF( WNTUA .AND. WNTVAS ) THEN
  428. *
  429. * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
  430. * 'A')
  431. *
  432. WRKBL = N + LWORK_CGEQRF
  433. WRKBL = MAX( WRKBL, N+LWORK_CUNGQR_M )
  434. WRKBL = MAX( WRKBL, 2*N+LWORK_CGEBRD )
  435. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_Q )
  436. WRKBL = MAX( WRKBL, 2*N+LWORK_CUNGBR_P )
  437. MAXWRK = N*N + WRKBL
  438. MINWRK = 2*N + M
  439. END IF
  440. ELSE
  441. *
  442. * Path 10 (M at least N, but not much larger)
  443. *
  444. CALL CGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
  445. $ CDUM(1), CDUM(1), -1, IERR )
  446. LWORK_CGEBRD = INT( CDUM(1) )
  447. MAXWRK = 2*N + LWORK_CGEBRD
  448. IF( WNTUS .OR. WNTUO ) THEN
  449. CALL CUNGBR( 'Q', M, N, N, A, LDA, CDUM(1),
  450. $ CDUM(1), -1, IERR )
  451. LWORK_CUNGBR_Q = INT( CDUM(1) )
  452. MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_Q )
  453. END IF
  454. IF( WNTUA ) THEN
  455. CALL CUNGBR( 'Q', M, M, N, A, LDA, CDUM(1),
  456. $ CDUM(1), -1, IERR )
  457. LWORK_CUNGBR_Q = INT( CDUM(1) )
  458. MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_Q )
  459. END IF
  460. IF( .NOT.WNTVN ) THEN
  461. MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_P )
  462. END IF
  463. MINWRK = 2*N + M
  464. END IF
  465. ELSE IF( MINMN.GT.0 ) THEN
  466. *
  467. * Space needed for CBDSQR is BDSPAC = 5*M
  468. *
  469. MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 )
  470. * Compute space needed for CGELQF
  471. CALL CGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
  472. LWORK_CGELQF = INT( CDUM(1) )
  473. * Compute space needed for CUNGLQ
  474. CALL CUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1,
  475. $ IERR )
  476. LWORK_CUNGLQ_N = INT( CDUM(1) )
  477. CALL CUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR )
  478. LWORK_CUNGLQ_M = INT( CDUM(1) )
  479. * Compute space needed for CGEBRD
  480. CALL CGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1),
  481. $ CDUM(1), CDUM(1), -1, IERR )
  482. LWORK_CGEBRD = INT( CDUM(1) )
  483. * Compute space needed for CUNGBR P
  484. CALL CUNGBR( 'P', M, M, M, A, N, CDUM(1),
  485. $ CDUM(1), -1, IERR )
  486. LWORK_CUNGBR_P = INT( CDUM(1) )
  487. * Compute space needed for CUNGBR Q
  488. CALL CUNGBR( 'Q', M, M, M, A, N, CDUM(1),
  489. $ CDUM(1), -1, IERR )
  490. LWORK_CUNGBR_Q = INT( CDUM(1) )
  491. IF( N.GE.MNTHR ) THEN
  492. IF( WNTVN ) THEN
  493. *
  494. * Path 1t(N much larger than M, JOBVT='N')
  495. *
  496. MAXWRK = M + LWORK_CGELQF
  497. MAXWRK = MAX( MAXWRK, 2*M+LWORK_CGEBRD )
  498. IF( WNTUO .OR. WNTUAS )
  499. $ MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_Q )
  500. MINWRK = 3*M
  501. ELSE IF( WNTVO .AND. WNTUN ) THEN
  502. *
  503. * Path 2t(N much larger than M, JOBU='N', JOBVT='O')
  504. *
  505. WRKBL = M + LWORK_CGELQF
  506. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_M )
  507. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  508. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  509. MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
  510. MINWRK = 2*M + N
  511. ELSE IF( WNTVO .AND. WNTUAS ) THEN
  512. *
  513. * Path 3t(N much larger than M, JOBU='S' or 'A',
  514. * JOBVT='O')
  515. *
  516. WRKBL = M + LWORK_CGELQF
  517. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_M )
  518. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  519. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  520. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_Q )
  521. MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
  522. MINWRK = 2*M + N
  523. ELSE IF( WNTVS .AND. WNTUN ) THEN
  524. *
  525. * Path 4t(N much larger than M, JOBU='N', JOBVT='S')
  526. *
  527. WRKBL = M + LWORK_CGELQF
  528. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_M )
  529. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  530. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  531. MAXWRK = M*M + WRKBL
  532. MINWRK = 2*M + N
  533. ELSE IF( WNTVS .AND. WNTUO ) THEN
  534. *
  535. * Path 5t(N much larger than M, JOBU='O', JOBVT='S')
  536. *
  537. WRKBL = M + LWORK_CGELQF
  538. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_M )
  539. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  540. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  541. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_Q )
  542. MAXWRK = 2*M*M + WRKBL
  543. MINWRK = 2*M + N
  544. ELSE IF( WNTVS .AND. WNTUAS ) THEN
  545. *
  546. * Path 6t(N much larger than M, JOBU='S' or 'A',
  547. * JOBVT='S')
  548. *
  549. WRKBL = M + LWORK_CGELQF
  550. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_M )
  551. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  552. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  553. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_Q )
  554. MAXWRK = M*M + WRKBL
  555. MINWRK = 2*M + N
  556. ELSE IF( WNTVA .AND. WNTUN ) THEN
  557. *
  558. * Path 7t(N much larger than M, JOBU='N', JOBVT='A')
  559. *
  560. WRKBL = M + LWORK_CGELQF
  561. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_N )
  562. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  563. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  564. MAXWRK = M*M + WRKBL
  565. MINWRK = 2*M + N
  566. ELSE IF( WNTVA .AND. WNTUO ) THEN
  567. *
  568. * Path 8t(N much larger than M, JOBU='O', JOBVT='A')
  569. *
  570. WRKBL = M + LWORK_CGELQF
  571. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_N )
  572. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  573. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  574. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_Q )
  575. MAXWRK = 2*M*M + WRKBL
  576. MINWRK = 2*M + N
  577. ELSE IF( WNTVA .AND. WNTUAS ) THEN
  578. *
  579. * Path 9t(N much larger than M, JOBU='S' or 'A',
  580. * JOBVT='A')
  581. *
  582. WRKBL = M + LWORK_CGELQF
  583. WRKBL = MAX( WRKBL, M+LWORK_CUNGLQ_N )
  584. WRKBL = MAX( WRKBL, 2*M+LWORK_CGEBRD )
  585. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_P )
  586. WRKBL = MAX( WRKBL, 2*M+LWORK_CUNGBR_Q )
  587. MAXWRK = M*M + WRKBL
  588. MINWRK = 2*M + N
  589. END IF
  590. ELSE
  591. *
  592. * Path 10t(N greater than M, but not much larger)
  593. *
  594. CALL CGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
  595. $ CDUM(1), CDUM(1), -1, IERR )
  596. LWORK_CGEBRD = INT( CDUM(1) )
  597. MAXWRK = 2*M + LWORK_CGEBRD
  598. IF( WNTVS .OR. WNTVO ) THEN
  599. * Compute space needed for CUNGBR P
  600. CALL CUNGBR( 'P', M, N, M, A, N, CDUM(1),
  601. $ CDUM(1), -1, IERR )
  602. LWORK_CUNGBR_P = INT( CDUM(1) )
  603. MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_P )
  604. END IF
  605. IF( WNTVA ) THEN
  606. CALL CUNGBR( 'P', N, N, M, A, N, CDUM(1),
  607. $ CDUM(1), -1, IERR )
  608. LWORK_CUNGBR_P = INT( CDUM(1) )
  609. MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_P )
  610. END IF
  611. IF( .NOT.WNTUN ) THEN
  612. MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_Q )
  613. END IF
  614. MINWRK = 2*M + N
  615. END IF
  616. END IF
  617. MAXWRK = MAX( MINWRK, MAXWRK )
  618. WORK( 1 ) = MAXWRK
  619. *
  620. IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
  621. INFO = -13
  622. END IF
  623. END IF
  624. *
  625. IF( INFO.NE.0 ) THEN
  626. CALL XERBLA( 'CGESVD', -INFO )
  627. RETURN
  628. ELSE IF( LQUERY ) THEN
  629. RETURN
  630. END IF
  631. *
  632. * Quick return if possible
  633. *
  634. IF( M.EQ.0 .OR. N.EQ.0 ) THEN
  635. RETURN
  636. END IF
  637. *
  638. * Get machine constants
  639. *
  640. EPS = SLAMCH( 'P' )
  641. SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
  642. BIGNUM = ONE / SMLNUM
  643. *
  644. * Scale A if max element outside range [SMLNUM,BIGNUM]
  645. *
  646. ANRM = CLANGE( 'M', M, N, A, LDA, DUM )
  647. ISCL = 0
  648. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
  649. ISCL = 1
  650. CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
  651. ELSE IF( ANRM.GT.BIGNUM ) THEN
  652. ISCL = 1
  653. CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
  654. END IF
  655. *
  656. IF( M.GE.N ) THEN
  657. *
  658. * A has at least as many rows as columns. If A has sufficiently
  659. * more rows than columns, first reduce using the QR
  660. * decomposition (if sufficient workspace available)
  661. *
  662. IF( M.GE.MNTHR ) THEN
  663. *
  664. IF( WNTUN ) THEN
  665. *
  666. * Path 1 (M much larger than N, JOBU='N')
  667. * No left singular vectors to be computed
  668. *
  669. ITAU = 1
  670. IWORK = ITAU + N
  671. *
  672. * Compute A=Q*R
  673. * (CWorkspace: need 2*N, prefer N+N*NB)
  674. * (RWorkspace: need 0)
  675. *
  676. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
  677. $ LWORK-IWORK+1, IERR )
  678. *
  679. * Zero out below R
  680. *
  681. IF( N .GT. 1 ) THEN
  682. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
  683. $ LDA )
  684. END IF
  685. IE = 1
  686. ITAUQ = 1
  687. ITAUP = ITAUQ + N
  688. IWORK = ITAUP + N
  689. *
  690. * Bidiagonalize R in A
  691. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  692. * (RWorkspace: need N)
  693. *
  694. CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
  695. $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
  696. $ IERR )
  697. NCVT = 0
  698. IF( WNTVO .OR. WNTVAS ) THEN
  699. *
  700. * If right singular vectors desired, generate P'.
  701. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  702. * (RWorkspace: 0)
  703. *
  704. CALL CUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
  705. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  706. NCVT = N
  707. END IF
  708. IRWORK = IE + N
  709. *
  710. * Perform bidiagonal QR iteration, computing right
  711. * singular vectors of A in A if desired
  712. * (CWorkspace: 0)
  713. * (RWorkspace: need BDSPAC)
  714. *
  715. CALL CBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
  716. $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
  717. *
  718. * If right singular vectors desired in VT, copy them there
  719. *
  720. IF( WNTVAS )
  721. $ CALL CLACPY( 'F', N, N, A, LDA, VT, LDVT )
  722. *
  723. ELSE IF( WNTUO .AND. WNTVN ) THEN
  724. *
  725. * Path 2 (M much larger than N, JOBU='O', JOBVT='N')
  726. * N left singular vectors to be overwritten on A and
  727. * no right singular vectors to be computed
  728. *
  729. IF( LWORK.GE.N*N+3*N ) THEN
  730. *
  731. * Sufficient workspace for a fast algorithm
  732. *
  733. IR = 1
  734. IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
  735. *
  736. * WORK(IU) is LDA by N, WORK(IR) is LDA by N
  737. *
  738. LDWRKU = LDA
  739. LDWRKR = LDA
  740. ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
  741. *
  742. * WORK(IU) is LDA by N, WORK(IR) is N by N
  743. *
  744. LDWRKU = LDA
  745. LDWRKR = N
  746. ELSE
  747. *
  748. * WORK(IU) is LDWRKU by N, WORK(IR) is N by N
  749. *
  750. LDWRKU = ( LWORK-N*N ) / N
  751. LDWRKR = N
  752. END IF
  753. ITAU = IR + LDWRKR*N
  754. IWORK = ITAU + N
  755. *
  756. * Compute A=Q*R
  757. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  758. * (RWorkspace: 0)
  759. *
  760. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  761. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  762. *
  763. * Copy R to WORK(IR) and zero out below it
  764. *
  765. CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
  766. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  767. $ WORK( IR+1 ), LDWRKR )
  768. *
  769. * Generate Q in A
  770. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  771. * (RWorkspace: 0)
  772. *
  773. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  774. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  775. IE = 1
  776. ITAUQ = ITAU
  777. ITAUP = ITAUQ + N
  778. IWORK = ITAUP + N
  779. *
  780. * Bidiagonalize R in WORK(IR)
  781. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  782. * (RWorkspace: need N)
  783. *
  784. CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
  785. $ WORK( ITAUQ ), WORK( ITAUP ),
  786. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  787. *
  788. * Generate left vectors bidiagonalizing R
  789. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  790. * (RWorkspace: need 0)
  791. *
  792. CALL CUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
  793. $ WORK( ITAUQ ), WORK( IWORK ),
  794. $ LWORK-IWORK+1, IERR )
  795. IRWORK = IE + N
  796. *
  797. * Perform bidiagonal QR iteration, computing left
  798. * singular vectors of R in WORK(IR)
  799. * (CWorkspace: need N*N)
  800. * (RWorkspace: need BDSPAC)
  801. *
  802. CALL CBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
  803. $ WORK( IR ), LDWRKR, CDUM, 1,
  804. $ RWORK( IRWORK ), INFO )
  805. IU = ITAUQ
  806. *
  807. * Multiply Q in A by left singular vectors of R in
  808. * WORK(IR), storing result in WORK(IU) and copying to A
  809. * (CWorkspace: need N*N+N, prefer N*N+M*N)
  810. * (RWorkspace: 0)
  811. *
  812. DO 10 I = 1, M, LDWRKU
  813. CHUNK = MIN( M-I+1, LDWRKU )
  814. CALL CGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
  815. $ LDA, WORK( IR ), LDWRKR, CZERO,
  816. $ WORK( IU ), LDWRKU )
  817. CALL CLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
  818. $ A( I, 1 ), LDA )
  819. 10 CONTINUE
  820. *
  821. ELSE
  822. *
  823. * Insufficient workspace for a fast algorithm
  824. *
  825. IE = 1
  826. ITAUQ = 1
  827. ITAUP = ITAUQ + N
  828. IWORK = ITAUP + N
  829. *
  830. * Bidiagonalize A
  831. * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
  832. * (RWorkspace: N)
  833. *
  834. CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ),
  835. $ WORK( ITAUQ ), WORK( ITAUP ),
  836. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  837. *
  838. * Generate left vectors bidiagonalizing A
  839. * (CWorkspace: need 3*N, prefer 2*N+N*NB)
  840. * (RWorkspace: 0)
  841. *
  842. CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
  843. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  844. IRWORK = IE + N
  845. *
  846. * Perform bidiagonal QR iteration, computing left
  847. * singular vectors of A in A
  848. * (CWorkspace: need 0)
  849. * (RWorkspace: need BDSPAC)
  850. *
  851. CALL CBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
  852. $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
  853. *
  854. END IF
  855. *
  856. ELSE IF( WNTUO .AND. WNTVAS ) THEN
  857. *
  858. * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
  859. * N left singular vectors to be overwritten on A and
  860. * N right singular vectors to be computed in VT
  861. *
  862. IF( LWORK.GE.N*N+3*N ) THEN
  863. *
  864. * Sufficient workspace for a fast algorithm
  865. *
  866. IR = 1
  867. IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
  868. *
  869. * WORK(IU) is LDA by N and WORK(IR) is LDA by N
  870. *
  871. LDWRKU = LDA
  872. LDWRKR = LDA
  873. ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
  874. *
  875. * WORK(IU) is LDA by N and WORK(IR) is N by N
  876. *
  877. LDWRKU = LDA
  878. LDWRKR = N
  879. ELSE
  880. *
  881. * WORK(IU) is LDWRKU by N and WORK(IR) is N by N
  882. *
  883. LDWRKU = ( LWORK-N*N ) / N
  884. LDWRKR = N
  885. END IF
  886. ITAU = IR + LDWRKR*N
  887. IWORK = ITAU + N
  888. *
  889. * Compute A=Q*R
  890. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  891. * (RWorkspace: 0)
  892. *
  893. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  894. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  895. *
  896. * Copy R to VT, zeroing out below it
  897. *
  898. CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
  899. IF( N.GT.1 )
  900. $ CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  901. $ VT( 2, 1 ), LDVT )
  902. *
  903. * Generate Q in A
  904. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  905. * (RWorkspace: 0)
  906. *
  907. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  908. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  909. IE = 1
  910. ITAUQ = ITAU
  911. ITAUP = ITAUQ + N
  912. IWORK = ITAUP + N
  913. *
  914. * Bidiagonalize R in VT, copying result to WORK(IR)
  915. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  916. * (RWorkspace: need N)
  917. *
  918. CALL CGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
  919. $ WORK( ITAUQ ), WORK( ITAUP ),
  920. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  921. CALL CLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
  922. *
  923. * Generate left vectors bidiagonalizing R in WORK(IR)
  924. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  925. * (RWorkspace: 0)
  926. *
  927. CALL CUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
  928. $ WORK( ITAUQ ), WORK( IWORK ),
  929. $ LWORK-IWORK+1, IERR )
  930. *
  931. * Generate right vectors bidiagonalizing R in VT
  932. * (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
  933. * (RWorkspace: 0)
  934. *
  935. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  936. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  937. IRWORK = IE + N
  938. *
  939. * Perform bidiagonal QR iteration, computing left
  940. * singular vectors of R in WORK(IR) and computing right
  941. * singular vectors of R in VT
  942. * (CWorkspace: need N*N)
  943. * (RWorkspace: need BDSPAC)
  944. *
  945. CALL CBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
  946. $ LDVT, WORK( IR ), LDWRKR, CDUM, 1,
  947. $ RWORK( IRWORK ), INFO )
  948. IU = ITAUQ
  949. *
  950. * Multiply Q in A by left singular vectors of R in
  951. * WORK(IR), storing result in WORK(IU) and copying to A
  952. * (CWorkspace: need N*N+N, prefer N*N+M*N)
  953. * (RWorkspace: 0)
  954. *
  955. DO 20 I = 1, M, LDWRKU
  956. CHUNK = MIN( M-I+1, LDWRKU )
  957. CALL CGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
  958. $ LDA, WORK( IR ), LDWRKR, CZERO,
  959. $ WORK( IU ), LDWRKU )
  960. CALL CLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
  961. $ A( I, 1 ), LDA )
  962. 20 CONTINUE
  963. *
  964. ELSE
  965. *
  966. * Insufficient workspace for a fast algorithm
  967. *
  968. ITAU = 1
  969. IWORK = ITAU + N
  970. *
  971. * Compute A=Q*R
  972. * (CWorkspace: need 2*N, prefer N+N*NB)
  973. * (RWorkspace: 0)
  974. *
  975. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  976. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  977. *
  978. * Copy R to VT, zeroing out below it
  979. *
  980. CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
  981. IF( N.GT.1 )
  982. $ CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  983. $ VT( 2, 1 ), LDVT )
  984. *
  985. * Generate Q in A
  986. * (CWorkspace: need 2*N, prefer N+N*NB)
  987. * (RWorkspace: 0)
  988. *
  989. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  990. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  991. IE = 1
  992. ITAUQ = ITAU
  993. ITAUP = ITAUQ + N
  994. IWORK = ITAUP + N
  995. *
  996. * Bidiagonalize R in VT
  997. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  998. * (RWorkspace: N)
  999. *
  1000. CALL CGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
  1001. $ WORK( ITAUQ ), WORK( ITAUP ),
  1002. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1003. *
  1004. * Multiply Q in A by left vectors bidiagonalizing R
  1005. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1006. * (RWorkspace: 0)
  1007. *
  1008. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
  1009. $ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
  1010. $ LWORK-IWORK+1, IERR )
  1011. *
  1012. * Generate right vectors bidiagonalizing R in VT
  1013. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  1014. * (RWorkspace: 0)
  1015. *
  1016. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  1017. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1018. IRWORK = IE + N
  1019. *
  1020. * Perform bidiagonal QR iteration, computing left
  1021. * singular vectors of A in A and computing right
  1022. * singular vectors of A in VT
  1023. * (CWorkspace: 0)
  1024. * (RWorkspace: need BDSPAC)
  1025. *
  1026. CALL CBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
  1027. $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
  1028. $ INFO )
  1029. *
  1030. END IF
  1031. *
  1032. ELSE IF( WNTUS ) THEN
  1033. *
  1034. IF( WNTVN ) THEN
  1035. *
  1036. * Path 4 (M much larger than N, JOBU='S', JOBVT='N')
  1037. * N left singular vectors to be computed in U and
  1038. * no right singular vectors to be computed
  1039. *
  1040. IF( LWORK.GE.N*N+3*N ) THEN
  1041. *
  1042. * Sufficient workspace for a fast algorithm
  1043. *
  1044. IR = 1
  1045. IF( LWORK.GE.WRKBL+LDA*N ) THEN
  1046. *
  1047. * WORK(IR) is LDA by N
  1048. *
  1049. LDWRKR = LDA
  1050. ELSE
  1051. *
  1052. * WORK(IR) is N by N
  1053. *
  1054. LDWRKR = N
  1055. END IF
  1056. ITAU = IR + LDWRKR*N
  1057. IWORK = ITAU + N
  1058. *
  1059. * Compute A=Q*R
  1060. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1061. * (RWorkspace: 0)
  1062. *
  1063. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1064. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1065. *
  1066. * Copy R to WORK(IR), zeroing out below it
  1067. *
  1068. CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ),
  1069. $ LDWRKR )
  1070. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1071. $ WORK( IR+1 ), LDWRKR )
  1072. *
  1073. * Generate Q in A
  1074. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1075. * (RWorkspace: 0)
  1076. *
  1077. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  1078. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1079. IE = 1
  1080. ITAUQ = ITAU
  1081. ITAUP = ITAUQ + N
  1082. IWORK = ITAUP + N
  1083. *
  1084. * Bidiagonalize R in WORK(IR)
  1085. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  1086. * (RWorkspace: need N)
  1087. *
  1088. CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S,
  1089. $ RWORK( IE ), WORK( ITAUQ ),
  1090. $ WORK( ITAUP ), WORK( IWORK ),
  1091. $ LWORK-IWORK+1, IERR )
  1092. *
  1093. * Generate left vectors bidiagonalizing R in WORK(IR)
  1094. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  1095. * (RWorkspace: 0)
  1096. *
  1097. CALL CUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
  1098. $ WORK( ITAUQ ), WORK( IWORK ),
  1099. $ LWORK-IWORK+1, IERR )
  1100. IRWORK = IE + N
  1101. *
  1102. * Perform bidiagonal QR iteration, computing left
  1103. * singular vectors of R in WORK(IR)
  1104. * (CWorkspace: need N*N)
  1105. * (RWorkspace: need BDSPAC)
  1106. *
  1107. CALL CBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
  1108. $ 1, WORK( IR ), LDWRKR, CDUM, 1,
  1109. $ RWORK( IRWORK ), INFO )
  1110. *
  1111. * Multiply Q in A by left singular vectors of R in
  1112. * WORK(IR), storing result in U
  1113. * (CWorkspace: need N*N)
  1114. * (RWorkspace: 0)
  1115. *
  1116. CALL CGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
  1117. $ WORK( IR ), LDWRKR, CZERO, U, LDU )
  1118. *
  1119. ELSE
  1120. *
  1121. * Insufficient workspace for a fast algorithm
  1122. *
  1123. ITAU = 1
  1124. IWORK = ITAU + N
  1125. *
  1126. * Compute A=Q*R, copying result to U
  1127. * (CWorkspace: need 2*N, prefer N+N*NB)
  1128. * (RWorkspace: 0)
  1129. *
  1130. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1131. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1132. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1133. *
  1134. * Generate Q in U
  1135. * (CWorkspace: need 2*N, prefer N+N*NB)
  1136. * (RWorkspace: 0)
  1137. *
  1138. CALL CUNGQR( M, N, N, U, LDU, WORK( ITAU ),
  1139. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1140. IE = 1
  1141. ITAUQ = ITAU
  1142. ITAUP = ITAUQ + N
  1143. IWORK = ITAUP + N
  1144. *
  1145. * Zero out below R in A
  1146. *
  1147. IF( N .GT. 1 ) THEN
  1148. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1149. $ A( 2, 1 ), LDA )
  1150. END IF
  1151. *
  1152. * Bidiagonalize R in A
  1153. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  1154. * (RWorkspace: need N)
  1155. *
  1156. CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ),
  1157. $ WORK( ITAUQ ), WORK( ITAUP ),
  1158. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1159. *
  1160. * Multiply Q in U by left vectors bidiagonalizing R
  1161. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1162. * (RWorkspace: 0)
  1163. *
  1164. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
  1165. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  1166. $ LWORK-IWORK+1, IERR )
  1167. IRWORK = IE + N
  1168. *
  1169. * Perform bidiagonal QR iteration, computing left
  1170. * singular vectors of A in U
  1171. * (CWorkspace: 0)
  1172. * (RWorkspace: need BDSPAC)
  1173. *
  1174. CALL CBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
  1175. $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
  1176. $ INFO )
  1177. *
  1178. END IF
  1179. *
  1180. ELSE IF( WNTVO ) THEN
  1181. *
  1182. * Path 5 (M much larger than N, JOBU='S', JOBVT='O')
  1183. * N left singular vectors to be computed in U and
  1184. * N right singular vectors to be overwritten on A
  1185. *
  1186. IF( LWORK.GE.2*N*N+3*N ) THEN
  1187. *
  1188. * Sufficient workspace for a fast algorithm
  1189. *
  1190. IU = 1
  1191. IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
  1192. *
  1193. * WORK(IU) is LDA by N and WORK(IR) is LDA by N
  1194. *
  1195. LDWRKU = LDA
  1196. IR = IU + LDWRKU*N
  1197. LDWRKR = LDA
  1198. ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
  1199. *
  1200. * WORK(IU) is LDA by N and WORK(IR) is N by N
  1201. *
  1202. LDWRKU = LDA
  1203. IR = IU + LDWRKU*N
  1204. LDWRKR = N
  1205. ELSE
  1206. *
  1207. * WORK(IU) is N by N and WORK(IR) is N by N
  1208. *
  1209. LDWRKU = N
  1210. IR = IU + LDWRKU*N
  1211. LDWRKR = N
  1212. END IF
  1213. ITAU = IR + LDWRKR*N
  1214. IWORK = ITAU + N
  1215. *
  1216. * Compute A=Q*R
  1217. * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
  1218. * (RWorkspace: 0)
  1219. *
  1220. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1221. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1222. *
  1223. * Copy R to WORK(IU), zeroing out below it
  1224. *
  1225. CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
  1226. $ LDWRKU )
  1227. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1228. $ WORK( IU+1 ), LDWRKU )
  1229. *
  1230. * Generate Q in A
  1231. * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
  1232. * (RWorkspace: 0)
  1233. *
  1234. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  1235. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1236. IE = 1
  1237. ITAUQ = ITAU
  1238. ITAUP = ITAUQ + N
  1239. IWORK = ITAUP + N
  1240. *
  1241. * Bidiagonalize R in WORK(IU), copying result to
  1242. * WORK(IR)
  1243. * (CWorkspace: need 2*N*N+3*N,
  1244. * prefer 2*N*N+2*N+2*N*NB)
  1245. * (RWorkspace: need N)
  1246. *
  1247. CALL CGEBRD( N, N, WORK( IU ), LDWRKU, S,
  1248. $ RWORK( IE ), WORK( ITAUQ ),
  1249. $ WORK( ITAUP ), WORK( IWORK ),
  1250. $ LWORK-IWORK+1, IERR )
  1251. CALL CLACPY( 'U', N, N, WORK( IU ), LDWRKU,
  1252. $ WORK( IR ), LDWRKR )
  1253. *
  1254. * Generate left bidiagonalizing vectors in WORK(IU)
  1255. * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
  1256. * (RWorkspace: 0)
  1257. *
  1258. CALL CUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
  1259. $ WORK( ITAUQ ), WORK( IWORK ),
  1260. $ LWORK-IWORK+1, IERR )
  1261. *
  1262. * Generate right bidiagonalizing vectors in WORK(IR)
  1263. * (CWorkspace: need 2*N*N+3*N-1,
  1264. * prefer 2*N*N+2*N+(N-1)*NB)
  1265. * (RWorkspace: 0)
  1266. *
  1267. CALL CUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
  1268. $ WORK( ITAUP ), WORK( IWORK ),
  1269. $ LWORK-IWORK+1, IERR )
  1270. IRWORK = IE + N
  1271. *
  1272. * Perform bidiagonal QR iteration, computing left
  1273. * singular vectors of R in WORK(IU) and computing
  1274. * right singular vectors of R in WORK(IR)
  1275. * (CWorkspace: need 2*N*N)
  1276. * (RWorkspace: need BDSPAC)
  1277. *
  1278. CALL CBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
  1279. $ WORK( IR ), LDWRKR, WORK( IU ),
  1280. $ LDWRKU, CDUM, 1, RWORK( IRWORK ),
  1281. $ INFO )
  1282. *
  1283. * Multiply Q in A by left singular vectors of R in
  1284. * WORK(IU), storing result in U
  1285. * (CWorkspace: need N*N)
  1286. * (RWorkspace: 0)
  1287. *
  1288. CALL CGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
  1289. $ WORK( IU ), LDWRKU, CZERO, U, LDU )
  1290. *
  1291. * Copy right singular vectors of R to A
  1292. * (CWorkspace: need N*N)
  1293. * (RWorkspace: 0)
  1294. *
  1295. CALL CLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
  1296. $ LDA )
  1297. *
  1298. ELSE
  1299. *
  1300. * Insufficient workspace for a fast algorithm
  1301. *
  1302. ITAU = 1
  1303. IWORK = ITAU + N
  1304. *
  1305. * Compute A=Q*R, copying result to U
  1306. * (CWorkspace: need 2*N, prefer N+N*NB)
  1307. * (RWorkspace: 0)
  1308. *
  1309. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1310. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1311. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1312. *
  1313. * Generate Q in U
  1314. * (CWorkspace: need 2*N, prefer N+N*NB)
  1315. * (RWorkspace: 0)
  1316. *
  1317. CALL CUNGQR( M, N, N, U, LDU, WORK( ITAU ),
  1318. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1319. IE = 1
  1320. ITAUQ = ITAU
  1321. ITAUP = ITAUQ + N
  1322. IWORK = ITAUP + N
  1323. *
  1324. * Zero out below R in A
  1325. *
  1326. IF( N .GT. 1 ) THEN
  1327. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1328. $ A( 2, 1 ), LDA )
  1329. END IF
  1330. *
  1331. * Bidiagonalize R in A
  1332. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  1333. * (RWorkspace: need N)
  1334. *
  1335. CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ),
  1336. $ WORK( ITAUQ ), WORK( ITAUP ),
  1337. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1338. *
  1339. * Multiply Q in U by left vectors bidiagonalizing R
  1340. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1341. * (RWorkspace: 0)
  1342. *
  1343. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
  1344. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  1345. $ LWORK-IWORK+1, IERR )
  1346. *
  1347. * Generate right vectors bidiagonalizing R in A
  1348. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  1349. * (RWorkspace: 0)
  1350. *
  1351. CALL CUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
  1352. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1353. IRWORK = IE + N
  1354. *
  1355. * Perform bidiagonal QR iteration, computing left
  1356. * singular vectors of A in U and computing right
  1357. * singular vectors of A in A
  1358. * (CWorkspace: 0)
  1359. * (RWorkspace: need BDSPAC)
  1360. *
  1361. CALL CBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
  1362. $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
  1363. $ INFO )
  1364. *
  1365. END IF
  1366. *
  1367. ELSE IF( WNTVAS ) THEN
  1368. *
  1369. * Path 6 (M much larger than N, JOBU='S', JOBVT='S'
  1370. * or 'A')
  1371. * N left singular vectors to be computed in U and
  1372. * N right singular vectors to be computed in VT
  1373. *
  1374. IF( LWORK.GE.N*N+3*N ) THEN
  1375. *
  1376. * Sufficient workspace for a fast algorithm
  1377. *
  1378. IU = 1
  1379. IF( LWORK.GE.WRKBL+LDA*N ) THEN
  1380. *
  1381. * WORK(IU) is LDA by N
  1382. *
  1383. LDWRKU = LDA
  1384. ELSE
  1385. *
  1386. * WORK(IU) is N by N
  1387. *
  1388. LDWRKU = N
  1389. END IF
  1390. ITAU = IU + LDWRKU*N
  1391. IWORK = ITAU + N
  1392. *
  1393. * Compute A=Q*R
  1394. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1395. * (RWorkspace: 0)
  1396. *
  1397. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1398. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1399. *
  1400. * Copy R to WORK(IU), zeroing out below it
  1401. *
  1402. CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
  1403. $ LDWRKU )
  1404. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1405. $ WORK( IU+1 ), LDWRKU )
  1406. *
  1407. * Generate Q in A
  1408. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1409. * (RWorkspace: 0)
  1410. *
  1411. CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
  1412. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1413. IE = 1
  1414. ITAUQ = ITAU
  1415. ITAUP = ITAUQ + N
  1416. IWORK = ITAUP + N
  1417. *
  1418. * Bidiagonalize R in WORK(IU), copying result to VT
  1419. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  1420. * (RWorkspace: need N)
  1421. *
  1422. CALL CGEBRD( N, N, WORK( IU ), LDWRKU, S,
  1423. $ RWORK( IE ), WORK( ITAUQ ),
  1424. $ WORK( ITAUP ), WORK( IWORK ),
  1425. $ LWORK-IWORK+1, IERR )
  1426. CALL CLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
  1427. $ LDVT )
  1428. *
  1429. * Generate left bidiagonalizing vectors in WORK(IU)
  1430. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  1431. * (RWorkspace: 0)
  1432. *
  1433. CALL CUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
  1434. $ WORK( ITAUQ ), WORK( IWORK ),
  1435. $ LWORK-IWORK+1, IERR )
  1436. *
  1437. * Generate right bidiagonalizing vectors in VT
  1438. * (CWorkspace: need N*N+3*N-1,
  1439. * prefer N*N+2*N+(N-1)*NB)
  1440. * (RWorkspace: 0)
  1441. *
  1442. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  1443. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1444. IRWORK = IE + N
  1445. *
  1446. * Perform bidiagonal QR iteration, computing left
  1447. * singular vectors of R in WORK(IU) and computing
  1448. * right singular vectors of R in VT
  1449. * (CWorkspace: need N*N)
  1450. * (RWorkspace: need BDSPAC)
  1451. *
  1452. CALL CBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
  1453. $ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
  1454. $ RWORK( IRWORK ), INFO )
  1455. *
  1456. * Multiply Q in A by left singular vectors of R in
  1457. * WORK(IU), storing result in U
  1458. * (CWorkspace: need N*N)
  1459. * (RWorkspace: 0)
  1460. *
  1461. CALL CGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
  1462. $ WORK( IU ), LDWRKU, CZERO, U, LDU )
  1463. *
  1464. ELSE
  1465. *
  1466. * Insufficient workspace for a fast algorithm
  1467. *
  1468. ITAU = 1
  1469. IWORK = ITAU + N
  1470. *
  1471. * Compute A=Q*R, copying result to U
  1472. * (CWorkspace: need 2*N, prefer N+N*NB)
  1473. * (RWorkspace: 0)
  1474. *
  1475. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1476. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1477. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1478. *
  1479. * Generate Q in U
  1480. * (CWorkspace: need 2*N, prefer N+N*NB)
  1481. * (RWorkspace: 0)
  1482. *
  1483. CALL CUNGQR( M, N, N, U, LDU, WORK( ITAU ),
  1484. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1485. *
  1486. * Copy R to VT, zeroing out below it
  1487. *
  1488. CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
  1489. IF( N.GT.1 )
  1490. $ CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1491. $ VT( 2, 1 ), LDVT )
  1492. IE = 1
  1493. ITAUQ = ITAU
  1494. ITAUP = ITAUQ + N
  1495. IWORK = ITAUP + N
  1496. *
  1497. * Bidiagonalize R in VT
  1498. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  1499. * (RWorkspace: need N)
  1500. *
  1501. CALL CGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
  1502. $ WORK( ITAUQ ), WORK( ITAUP ),
  1503. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1504. *
  1505. * Multiply Q in U by left bidiagonalizing vectors
  1506. * in VT
  1507. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1508. * (RWorkspace: 0)
  1509. *
  1510. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
  1511. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  1512. $ LWORK-IWORK+1, IERR )
  1513. *
  1514. * Generate right bidiagonalizing vectors in VT
  1515. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  1516. * (RWorkspace: 0)
  1517. *
  1518. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  1519. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1520. IRWORK = IE + N
  1521. *
  1522. * Perform bidiagonal QR iteration, computing left
  1523. * singular vectors of A in U and computing right
  1524. * singular vectors of A in VT
  1525. * (CWorkspace: 0)
  1526. * (RWorkspace: need BDSPAC)
  1527. *
  1528. CALL CBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
  1529. $ LDVT, U, LDU, CDUM, 1,
  1530. $ RWORK( IRWORK ), INFO )
  1531. *
  1532. END IF
  1533. *
  1534. END IF
  1535. *
  1536. ELSE IF( WNTUA ) THEN
  1537. *
  1538. IF( WNTVN ) THEN
  1539. *
  1540. * Path 7 (M much larger than N, JOBU='A', JOBVT='N')
  1541. * M left singular vectors to be computed in U and
  1542. * no right singular vectors to be computed
  1543. *
  1544. IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
  1545. *
  1546. * Sufficient workspace for a fast algorithm
  1547. *
  1548. IR = 1
  1549. IF( LWORK.GE.WRKBL+LDA*N ) THEN
  1550. *
  1551. * WORK(IR) is LDA by N
  1552. *
  1553. LDWRKR = LDA
  1554. ELSE
  1555. *
  1556. * WORK(IR) is N by N
  1557. *
  1558. LDWRKR = N
  1559. END IF
  1560. ITAU = IR + LDWRKR*N
  1561. IWORK = ITAU + N
  1562. *
  1563. * Compute A=Q*R, copying result to U
  1564. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1565. * (RWorkspace: 0)
  1566. *
  1567. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1568. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1569. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1570. *
  1571. * Copy R to WORK(IR), zeroing out below it
  1572. *
  1573. CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ),
  1574. $ LDWRKR )
  1575. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1576. $ WORK( IR+1 ), LDWRKR )
  1577. *
  1578. * Generate Q in U
  1579. * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
  1580. * (RWorkspace: 0)
  1581. *
  1582. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  1583. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1584. IE = 1
  1585. ITAUQ = ITAU
  1586. ITAUP = ITAUQ + N
  1587. IWORK = ITAUP + N
  1588. *
  1589. * Bidiagonalize R in WORK(IR)
  1590. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  1591. * (RWorkspace: need N)
  1592. *
  1593. CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S,
  1594. $ RWORK( IE ), WORK( ITAUQ ),
  1595. $ WORK( ITAUP ), WORK( IWORK ),
  1596. $ LWORK-IWORK+1, IERR )
  1597. *
  1598. * Generate left bidiagonalizing vectors in WORK(IR)
  1599. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  1600. * (RWorkspace: 0)
  1601. *
  1602. CALL CUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
  1603. $ WORK( ITAUQ ), WORK( IWORK ),
  1604. $ LWORK-IWORK+1, IERR )
  1605. IRWORK = IE + N
  1606. *
  1607. * Perform bidiagonal QR iteration, computing left
  1608. * singular vectors of R in WORK(IR)
  1609. * (CWorkspace: need N*N)
  1610. * (RWorkspace: need BDSPAC)
  1611. *
  1612. CALL CBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
  1613. $ 1, WORK( IR ), LDWRKR, CDUM, 1,
  1614. $ RWORK( IRWORK ), INFO )
  1615. *
  1616. * Multiply Q in U by left singular vectors of R in
  1617. * WORK(IR), storing result in A
  1618. * (CWorkspace: need N*N)
  1619. * (RWorkspace: 0)
  1620. *
  1621. CALL CGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
  1622. $ WORK( IR ), LDWRKR, CZERO, A, LDA )
  1623. *
  1624. * Copy left singular vectors of A from A to U
  1625. *
  1626. CALL CLACPY( 'F', M, N, A, LDA, U, LDU )
  1627. *
  1628. ELSE
  1629. *
  1630. * Insufficient workspace for a fast algorithm
  1631. *
  1632. ITAU = 1
  1633. IWORK = ITAU + N
  1634. *
  1635. * Compute A=Q*R, copying result to U
  1636. * (CWorkspace: need 2*N, prefer N+N*NB)
  1637. * (RWorkspace: 0)
  1638. *
  1639. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1640. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1641. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1642. *
  1643. * Generate Q in U
  1644. * (CWorkspace: need N+M, prefer N+M*NB)
  1645. * (RWorkspace: 0)
  1646. *
  1647. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  1648. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1649. IE = 1
  1650. ITAUQ = ITAU
  1651. ITAUP = ITAUQ + N
  1652. IWORK = ITAUP + N
  1653. *
  1654. * Zero out below R in A
  1655. *
  1656. IF( N .GT. 1 ) THEN
  1657. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1658. $ A( 2, 1 ), LDA )
  1659. END IF
  1660. *
  1661. * Bidiagonalize R in A
  1662. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  1663. * (RWorkspace: need N)
  1664. *
  1665. CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ),
  1666. $ WORK( ITAUQ ), WORK( ITAUP ),
  1667. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1668. *
  1669. * Multiply Q in U by left bidiagonalizing vectors
  1670. * in A
  1671. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1672. * (RWorkspace: 0)
  1673. *
  1674. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
  1675. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  1676. $ LWORK-IWORK+1, IERR )
  1677. IRWORK = IE + N
  1678. *
  1679. * Perform bidiagonal QR iteration, computing left
  1680. * singular vectors of A in U
  1681. * (CWorkspace: 0)
  1682. * (RWorkspace: need BDSPAC)
  1683. *
  1684. CALL CBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
  1685. $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
  1686. $ INFO )
  1687. *
  1688. END IF
  1689. *
  1690. ELSE IF( WNTVO ) THEN
  1691. *
  1692. * Path 8 (M much larger than N, JOBU='A', JOBVT='O')
  1693. * M left singular vectors to be computed in U and
  1694. * N right singular vectors to be overwritten on A
  1695. *
  1696. IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
  1697. *
  1698. * Sufficient workspace for a fast algorithm
  1699. *
  1700. IU = 1
  1701. IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
  1702. *
  1703. * WORK(IU) is LDA by N and WORK(IR) is LDA by N
  1704. *
  1705. LDWRKU = LDA
  1706. IR = IU + LDWRKU*N
  1707. LDWRKR = LDA
  1708. ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
  1709. *
  1710. * WORK(IU) is LDA by N and WORK(IR) is N by N
  1711. *
  1712. LDWRKU = LDA
  1713. IR = IU + LDWRKU*N
  1714. LDWRKR = N
  1715. ELSE
  1716. *
  1717. * WORK(IU) is N by N and WORK(IR) is N by N
  1718. *
  1719. LDWRKU = N
  1720. IR = IU + LDWRKU*N
  1721. LDWRKR = N
  1722. END IF
  1723. ITAU = IR + LDWRKR*N
  1724. IWORK = ITAU + N
  1725. *
  1726. * Compute A=Q*R, copying result to U
  1727. * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
  1728. * (RWorkspace: 0)
  1729. *
  1730. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1731. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1732. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1733. *
  1734. * Generate Q in U
  1735. * (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
  1736. * (RWorkspace: 0)
  1737. *
  1738. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  1739. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1740. *
  1741. * Copy R to WORK(IU), zeroing out below it
  1742. *
  1743. CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
  1744. $ LDWRKU )
  1745. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1746. $ WORK( IU+1 ), LDWRKU )
  1747. IE = 1
  1748. ITAUQ = ITAU
  1749. ITAUP = ITAUQ + N
  1750. IWORK = ITAUP + N
  1751. *
  1752. * Bidiagonalize R in WORK(IU), copying result to
  1753. * WORK(IR)
  1754. * (CWorkspace: need 2*N*N+3*N,
  1755. * prefer 2*N*N+2*N+2*N*NB)
  1756. * (RWorkspace: need N)
  1757. *
  1758. CALL CGEBRD( N, N, WORK( IU ), LDWRKU, S,
  1759. $ RWORK( IE ), WORK( ITAUQ ),
  1760. $ WORK( ITAUP ), WORK( IWORK ),
  1761. $ LWORK-IWORK+1, IERR )
  1762. CALL CLACPY( 'U', N, N, WORK( IU ), LDWRKU,
  1763. $ WORK( IR ), LDWRKR )
  1764. *
  1765. * Generate left bidiagonalizing vectors in WORK(IU)
  1766. * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
  1767. * (RWorkspace: 0)
  1768. *
  1769. CALL CUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
  1770. $ WORK( ITAUQ ), WORK( IWORK ),
  1771. $ LWORK-IWORK+1, IERR )
  1772. *
  1773. * Generate right bidiagonalizing vectors in WORK(IR)
  1774. * (CWorkspace: need 2*N*N+3*N-1,
  1775. * prefer 2*N*N+2*N+(N-1)*NB)
  1776. * (RWorkspace: 0)
  1777. *
  1778. CALL CUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
  1779. $ WORK( ITAUP ), WORK( IWORK ),
  1780. $ LWORK-IWORK+1, IERR )
  1781. IRWORK = IE + N
  1782. *
  1783. * Perform bidiagonal QR iteration, computing left
  1784. * singular vectors of R in WORK(IU) and computing
  1785. * right singular vectors of R in WORK(IR)
  1786. * (CWorkspace: need 2*N*N)
  1787. * (RWorkspace: need BDSPAC)
  1788. *
  1789. CALL CBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
  1790. $ WORK( IR ), LDWRKR, WORK( IU ),
  1791. $ LDWRKU, CDUM, 1, RWORK( IRWORK ),
  1792. $ INFO )
  1793. *
  1794. * Multiply Q in U by left singular vectors of R in
  1795. * WORK(IU), storing result in A
  1796. * (CWorkspace: need N*N)
  1797. * (RWorkspace: 0)
  1798. *
  1799. CALL CGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
  1800. $ WORK( IU ), LDWRKU, CZERO, A, LDA )
  1801. *
  1802. * Copy left singular vectors of A from A to U
  1803. *
  1804. CALL CLACPY( 'F', M, N, A, LDA, U, LDU )
  1805. *
  1806. * Copy right singular vectors of R from WORK(IR) to A
  1807. *
  1808. CALL CLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
  1809. $ LDA )
  1810. *
  1811. ELSE
  1812. *
  1813. * Insufficient workspace for a fast algorithm
  1814. *
  1815. ITAU = 1
  1816. IWORK = ITAU + N
  1817. *
  1818. * Compute A=Q*R, copying result to U
  1819. * (CWorkspace: need 2*N, prefer N+N*NB)
  1820. * (RWorkspace: 0)
  1821. *
  1822. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1823. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1824. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1825. *
  1826. * Generate Q in U
  1827. * (CWorkspace: need N+M, prefer N+M*NB)
  1828. * (RWorkspace: 0)
  1829. *
  1830. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  1831. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1832. IE = 1
  1833. ITAUQ = ITAU
  1834. ITAUP = ITAUQ + N
  1835. IWORK = ITAUP + N
  1836. *
  1837. * Zero out below R in A
  1838. *
  1839. IF( N .GT. 1 ) THEN
  1840. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1841. $ A( 2, 1 ), LDA )
  1842. END IF
  1843. *
  1844. * Bidiagonalize R in A
  1845. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  1846. * (RWorkspace: need N)
  1847. *
  1848. CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ),
  1849. $ WORK( ITAUQ ), WORK( ITAUP ),
  1850. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1851. *
  1852. * Multiply Q in U by left bidiagonalizing vectors
  1853. * in A
  1854. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  1855. * (RWorkspace: 0)
  1856. *
  1857. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
  1858. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  1859. $ LWORK-IWORK+1, IERR )
  1860. *
  1861. * Generate right bidiagonalizing vectors in A
  1862. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  1863. * (RWorkspace: 0)
  1864. *
  1865. CALL CUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
  1866. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1867. IRWORK = IE + N
  1868. *
  1869. * Perform bidiagonal QR iteration, computing left
  1870. * singular vectors of A in U and computing right
  1871. * singular vectors of A in A
  1872. * (CWorkspace: 0)
  1873. * (RWorkspace: need BDSPAC)
  1874. *
  1875. CALL CBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
  1876. $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
  1877. $ INFO )
  1878. *
  1879. END IF
  1880. *
  1881. ELSE IF( WNTVAS ) THEN
  1882. *
  1883. * Path 9 (M much larger than N, JOBU='A', JOBVT='S'
  1884. * or 'A')
  1885. * M left singular vectors to be computed in U and
  1886. * N right singular vectors to be computed in VT
  1887. *
  1888. IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
  1889. *
  1890. * Sufficient workspace for a fast algorithm
  1891. *
  1892. IU = 1
  1893. IF( LWORK.GE.WRKBL+LDA*N ) THEN
  1894. *
  1895. * WORK(IU) is LDA by N
  1896. *
  1897. LDWRKU = LDA
  1898. ELSE
  1899. *
  1900. * WORK(IU) is N by N
  1901. *
  1902. LDWRKU = N
  1903. END IF
  1904. ITAU = IU + LDWRKU*N
  1905. IWORK = ITAU + N
  1906. *
  1907. * Compute A=Q*R, copying result to U
  1908. * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
  1909. * (RWorkspace: 0)
  1910. *
  1911. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1912. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1913. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1914. *
  1915. * Generate Q in U
  1916. * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
  1917. * (RWorkspace: 0)
  1918. *
  1919. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  1920. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1921. *
  1922. * Copy R to WORK(IU), zeroing out below it
  1923. *
  1924. CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
  1925. $ LDWRKU )
  1926. CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  1927. $ WORK( IU+1 ), LDWRKU )
  1928. IE = 1
  1929. ITAUQ = ITAU
  1930. ITAUP = ITAUQ + N
  1931. IWORK = ITAUP + N
  1932. *
  1933. * Bidiagonalize R in WORK(IU), copying result to VT
  1934. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
  1935. * (RWorkspace: need N)
  1936. *
  1937. CALL CGEBRD( N, N, WORK( IU ), LDWRKU, S,
  1938. $ RWORK( IE ), WORK( ITAUQ ),
  1939. $ WORK( ITAUP ), WORK( IWORK ),
  1940. $ LWORK-IWORK+1, IERR )
  1941. CALL CLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
  1942. $ LDVT )
  1943. *
  1944. * Generate left bidiagonalizing vectors in WORK(IU)
  1945. * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
  1946. * (RWorkspace: 0)
  1947. *
  1948. CALL CUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
  1949. $ WORK( ITAUQ ), WORK( IWORK ),
  1950. $ LWORK-IWORK+1, IERR )
  1951. *
  1952. * Generate right bidiagonalizing vectors in VT
  1953. * (CWorkspace: need N*N+3*N-1,
  1954. * prefer N*N+2*N+(N-1)*NB)
  1955. * (RWorkspace: need 0)
  1956. *
  1957. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  1958. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1959. IRWORK = IE + N
  1960. *
  1961. * Perform bidiagonal QR iteration, computing left
  1962. * singular vectors of R in WORK(IU) and computing
  1963. * right singular vectors of R in VT
  1964. * (CWorkspace: need N*N)
  1965. * (RWorkspace: need BDSPAC)
  1966. *
  1967. CALL CBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
  1968. $ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
  1969. $ RWORK( IRWORK ), INFO )
  1970. *
  1971. * Multiply Q in U by left singular vectors of R in
  1972. * WORK(IU), storing result in A
  1973. * (CWorkspace: need N*N)
  1974. * (RWorkspace: 0)
  1975. *
  1976. CALL CGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
  1977. $ WORK( IU ), LDWRKU, CZERO, A, LDA )
  1978. *
  1979. * Copy left singular vectors of A from A to U
  1980. *
  1981. CALL CLACPY( 'F', M, N, A, LDA, U, LDU )
  1982. *
  1983. ELSE
  1984. *
  1985. * Insufficient workspace for a fast algorithm
  1986. *
  1987. ITAU = 1
  1988. IWORK = ITAU + N
  1989. *
  1990. * Compute A=Q*R, copying result to U
  1991. * (CWorkspace: need 2*N, prefer N+N*NB)
  1992. * (RWorkspace: 0)
  1993. *
  1994. CALL CGEQRF( M, N, A, LDA, WORK( ITAU ),
  1995. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  1996. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  1997. *
  1998. * Generate Q in U
  1999. * (CWorkspace: need N+M, prefer N+M*NB)
  2000. * (RWorkspace: 0)
  2001. *
  2002. CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
  2003. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2004. *
  2005. * Copy R from A to VT, zeroing out below it
  2006. *
  2007. CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
  2008. IF( N.GT.1 )
  2009. $ CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
  2010. $ VT( 2, 1 ), LDVT )
  2011. IE = 1
  2012. ITAUQ = ITAU
  2013. ITAUP = ITAUQ + N
  2014. IWORK = ITAUP + N
  2015. *
  2016. * Bidiagonalize R in VT
  2017. * (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
  2018. * (RWorkspace: need N)
  2019. *
  2020. CALL CGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
  2021. $ WORK( ITAUQ ), WORK( ITAUP ),
  2022. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2023. *
  2024. * Multiply Q in U by left bidiagonalizing vectors
  2025. * in VT
  2026. * (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
  2027. * (RWorkspace: 0)
  2028. *
  2029. CALL CUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
  2030. $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
  2031. $ LWORK-IWORK+1, IERR )
  2032. *
  2033. * Generate right bidiagonalizing vectors in VT
  2034. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  2035. * (RWorkspace: 0)
  2036. *
  2037. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  2038. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2039. IRWORK = IE + N
  2040. *
  2041. * Perform bidiagonal QR iteration, computing left
  2042. * singular vectors of A in U and computing right
  2043. * singular vectors of A in VT
  2044. * (CWorkspace: 0)
  2045. * (RWorkspace: need BDSPAC)
  2046. *
  2047. CALL CBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
  2048. $ LDVT, U, LDU, CDUM, 1,
  2049. $ RWORK( IRWORK ), INFO )
  2050. *
  2051. END IF
  2052. *
  2053. END IF
  2054. *
  2055. END IF
  2056. *
  2057. ELSE
  2058. *
  2059. * M .LT. MNTHR
  2060. *
  2061. * Path 10 (M at least N, but not much larger)
  2062. * Reduce to bidiagonal form without QR decomposition
  2063. *
  2064. IE = 1
  2065. ITAUQ = 1
  2066. ITAUP = ITAUQ + N
  2067. IWORK = ITAUP + N
  2068. *
  2069. * Bidiagonalize A
  2070. * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
  2071. * (RWorkspace: need N)
  2072. *
  2073. CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
  2074. $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
  2075. $ IERR )
  2076. IF( WNTUAS ) THEN
  2077. *
  2078. * If left singular vectors desired in U, copy result to U
  2079. * and generate left bidiagonalizing vectors in U
  2080. * (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
  2081. * (RWorkspace: 0)
  2082. *
  2083. CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
  2084. IF( WNTUS )
  2085. $ NCU = N
  2086. IF( WNTUA )
  2087. $ NCU = M
  2088. CALL CUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
  2089. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2090. END IF
  2091. IF( WNTVAS ) THEN
  2092. *
  2093. * If right singular vectors desired in VT, copy result to
  2094. * VT and generate right bidiagonalizing vectors in VT
  2095. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  2096. * (RWorkspace: 0)
  2097. *
  2098. CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
  2099. CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
  2100. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2101. END IF
  2102. IF( WNTUO ) THEN
  2103. *
  2104. * If left singular vectors desired in A, generate left
  2105. * bidiagonalizing vectors in A
  2106. * (CWorkspace: need 3*N, prefer 2*N+N*NB)
  2107. * (RWorkspace: 0)
  2108. *
  2109. CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
  2110. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2111. END IF
  2112. IF( WNTVO ) THEN
  2113. *
  2114. * If right singular vectors desired in A, generate right
  2115. * bidiagonalizing vectors in A
  2116. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
  2117. * (RWorkspace: 0)
  2118. *
  2119. CALL CUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
  2120. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2121. END IF
  2122. IRWORK = IE + N
  2123. IF( WNTUAS .OR. WNTUO )
  2124. $ NRU = M
  2125. IF( WNTUN )
  2126. $ NRU = 0
  2127. IF( WNTVAS .OR. WNTVO )
  2128. $ NCVT = N
  2129. IF( WNTVN )
  2130. $ NCVT = 0
  2131. IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
  2132. *
  2133. * Perform bidiagonal QR iteration, if desired, computing
  2134. * left singular vectors in U and computing right singular
  2135. * vectors in VT
  2136. * (CWorkspace: 0)
  2137. * (RWorkspace: need BDSPAC)
  2138. *
  2139. CALL CBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
  2140. $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
  2141. $ INFO )
  2142. ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
  2143. *
  2144. * Perform bidiagonal QR iteration, if desired, computing
  2145. * left singular vectors in U and computing right singular
  2146. * vectors in A
  2147. * (CWorkspace: 0)
  2148. * (RWorkspace: need BDSPAC)
  2149. *
  2150. CALL CBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
  2151. $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
  2152. $ INFO )
  2153. ELSE
  2154. *
  2155. * Perform bidiagonal QR iteration, if desired, computing
  2156. * left singular vectors in A and computing right singular
  2157. * vectors in VT
  2158. * (CWorkspace: 0)
  2159. * (RWorkspace: need BDSPAC)
  2160. *
  2161. CALL CBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
  2162. $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
  2163. $ INFO )
  2164. END IF
  2165. *
  2166. END IF
  2167. *
  2168. ELSE
  2169. *
  2170. * A has more columns than rows. If A has sufficiently more
  2171. * columns than rows, first reduce using the LQ decomposition (if
  2172. * sufficient workspace available)
  2173. *
  2174. IF( N.GE.MNTHR ) THEN
  2175. *
  2176. IF( WNTVN ) THEN
  2177. *
  2178. * Path 1t(N much larger than M, JOBVT='N')
  2179. * No right singular vectors to be computed
  2180. *
  2181. ITAU = 1
  2182. IWORK = ITAU + M
  2183. *
  2184. * Compute A=L*Q
  2185. * (CWorkspace: need 2*M, prefer M+M*NB)
  2186. * (RWorkspace: 0)
  2187. *
  2188. CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
  2189. $ LWORK-IWORK+1, IERR )
  2190. *
  2191. * Zero out above L
  2192. *
  2193. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
  2194. $ LDA )
  2195. IE = 1
  2196. ITAUQ = 1
  2197. ITAUP = ITAUQ + M
  2198. IWORK = ITAUP + M
  2199. *
  2200. * Bidiagonalize L in A
  2201. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  2202. * (RWorkspace: need M)
  2203. *
  2204. CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
  2205. $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
  2206. $ IERR )
  2207. IF( WNTUO .OR. WNTUAS ) THEN
  2208. *
  2209. * If left singular vectors desired, generate Q
  2210. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  2211. * (RWorkspace: 0)
  2212. *
  2213. CALL CUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
  2214. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2215. END IF
  2216. IRWORK = IE + M
  2217. NRU = 0
  2218. IF( WNTUO .OR. WNTUAS )
  2219. $ NRU = M
  2220. *
  2221. * Perform bidiagonal QR iteration, computing left singular
  2222. * vectors of A in A if desired
  2223. * (CWorkspace: 0)
  2224. * (RWorkspace: need BDSPAC)
  2225. *
  2226. CALL CBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
  2227. $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
  2228. *
  2229. * If left singular vectors desired in U, copy them there
  2230. *
  2231. IF( WNTUAS )
  2232. $ CALL CLACPY( 'F', M, M, A, LDA, U, LDU )
  2233. *
  2234. ELSE IF( WNTVO .AND. WNTUN ) THEN
  2235. *
  2236. * Path 2t(N much larger than M, JOBU='N', JOBVT='O')
  2237. * M right singular vectors to be overwritten on A and
  2238. * no left singular vectors to be computed
  2239. *
  2240. IF( LWORK.GE.M*M+3*M ) THEN
  2241. *
  2242. * Sufficient workspace for a fast algorithm
  2243. *
  2244. IR = 1
  2245. IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
  2246. *
  2247. * WORK(IU) is LDA by N and WORK(IR) is LDA by M
  2248. *
  2249. LDWRKU = LDA
  2250. CHUNK = N
  2251. LDWRKR = LDA
  2252. ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
  2253. *
  2254. * WORK(IU) is LDA by N and WORK(IR) is M by M
  2255. *
  2256. LDWRKU = LDA
  2257. CHUNK = N
  2258. LDWRKR = M
  2259. ELSE
  2260. *
  2261. * WORK(IU) is M by CHUNK and WORK(IR) is M by M
  2262. *
  2263. LDWRKU = M
  2264. CHUNK = ( LWORK-M*M ) / M
  2265. LDWRKR = M
  2266. END IF
  2267. ITAU = IR + LDWRKR*M
  2268. IWORK = ITAU + M
  2269. *
  2270. * Compute A=L*Q
  2271. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2272. * (RWorkspace: 0)
  2273. *
  2274. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2275. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2276. *
  2277. * Copy L to WORK(IR) and zero out above it
  2278. *
  2279. CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
  2280. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2281. $ WORK( IR+LDWRKR ), LDWRKR )
  2282. *
  2283. * Generate Q in A
  2284. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2285. * (RWorkspace: 0)
  2286. *
  2287. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2288. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2289. IE = 1
  2290. ITAUQ = ITAU
  2291. ITAUP = ITAUQ + M
  2292. IWORK = ITAUP + M
  2293. *
  2294. * Bidiagonalize L in WORK(IR)
  2295. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  2296. * (RWorkspace: need M)
  2297. *
  2298. CALL CGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
  2299. $ WORK( ITAUQ ), WORK( ITAUP ),
  2300. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2301. *
  2302. * Generate right vectors bidiagonalizing L
  2303. * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
  2304. * (RWorkspace: 0)
  2305. *
  2306. CALL CUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
  2307. $ WORK( ITAUP ), WORK( IWORK ),
  2308. $ LWORK-IWORK+1, IERR )
  2309. IRWORK = IE + M
  2310. *
  2311. * Perform bidiagonal QR iteration, computing right
  2312. * singular vectors of L in WORK(IR)
  2313. * (CWorkspace: need M*M)
  2314. * (RWorkspace: need BDSPAC)
  2315. *
  2316. CALL CBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
  2317. $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
  2318. $ RWORK( IRWORK ), INFO )
  2319. IU = ITAUQ
  2320. *
  2321. * Multiply right singular vectors of L in WORK(IR) by Q
  2322. * in A, storing result in WORK(IU) and copying to A
  2323. * (CWorkspace: need M*M+M, prefer M*M+M*N)
  2324. * (RWorkspace: 0)
  2325. *
  2326. DO 30 I = 1, N, CHUNK
  2327. BLK = MIN( N-I+1, CHUNK )
  2328. CALL CGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
  2329. $ LDWRKR, A( 1, I ), LDA, CZERO,
  2330. $ WORK( IU ), LDWRKU )
  2331. CALL CLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
  2332. $ A( 1, I ), LDA )
  2333. 30 CONTINUE
  2334. *
  2335. ELSE
  2336. *
  2337. * Insufficient workspace for a fast algorithm
  2338. *
  2339. IE = 1
  2340. ITAUQ = 1
  2341. ITAUP = ITAUQ + M
  2342. IWORK = ITAUP + M
  2343. *
  2344. * Bidiagonalize A
  2345. * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
  2346. * (RWorkspace: need M)
  2347. *
  2348. CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ),
  2349. $ WORK( ITAUQ ), WORK( ITAUP ),
  2350. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2351. *
  2352. * Generate right vectors bidiagonalizing A
  2353. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  2354. * (RWorkspace: 0)
  2355. *
  2356. CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
  2357. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2358. IRWORK = IE + M
  2359. *
  2360. * Perform bidiagonal QR iteration, computing right
  2361. * singular vectors of A in A
  2362. * (CWorkspace: 0)
  2363. * (RWorkspace: need BDSPAC)
  2364. *
  2365. CALL CBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
  2366. $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
  2367. *
  2368. END IF
  2369. *
  2370. ELSE IF( WNTVO .AND. WNTUAS ) THEN
  2371. *
  2372. * Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
  2373. * M right singular vectors to be overwritten on A and
  2374. * M left singular vectors to be computed in U
  2375. *
  2376. IF( LWORK.GE.M*M+3*M ) THEN
  2377. *
  2378. * Sufficient workspace for a fast algorithm
  2379. *
  2380. IR = 1
  2381. IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
  2382. *
  2383. * WORK(IU) is LDA by N and WORK(IR) is LDA by M
  2384. *
  2385. LDWRKU = LDA
  2386. CHUNK = N
  2387. LDWRKR = LDA
  2388. ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
  2389. *
  2390. * WORK(IU) is LDA by N and WORK(IR) is M by M
  2391. *
  2392. LDWRKU = LDA
  2393. CHUNK = N
  2394. LDWRKR = M
  2395. ELSE
  2396. *
  2397. * WORK(IU) is M by CHUNK and WORK(IR) is M by M
  2398. *
  2399. LDWRKU = M
  2400. CHUNK = ( LWORK-M*M ) / M
  2401. LDWRKR = M
  2402. END IF
  2403. ITAU = IR + LDWRKR*M
  2404. IWORK = ITAU + M
  2405. *
  2406. * Compute A=L*Q
  2407. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2408. * (RWorkspace: 0)
  2409. *
  2410. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2411. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2412. *
  2413. * Copy L to U, zeroing about above it
  2414. *
  2415. CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
  2416. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
  2417. $ LDU )
  2418. *
  2419. * Generate Q in A
  2420. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2421. * (RWorkspace: 0)
  2422. *
  2423. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2424. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2425. IE = 1
  2426. ITAUQ = ITAU
  2427. ITAUP = ITAUQ + M
  2428. IWORK = ITAUP + M
  2429. *
  2430. * Bidiagonalize L in U, copying result to WORK(IR)
  2431. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  2432. * (RWorkspace: need M)
  2433. *
  2434. CALL CGEBRD( M, M, U, LDU, S, RWORK( IE ),
  2435. $ WORK( ITAUQ ), WORK( ITAUP ),
  2436. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2437. CALL CLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
  2438. *
  2439. * Generate right vectors bidiagonalizing L in WORK(IR)
  2440. * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
  2441. * (RWorkspace: 0)
  2442. *
  2443. CALL CUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
  2444. $ WORK( ITAUP ), WORK( IWORK ),
  2445. $ LWORK-IWORK+1, IERR )
  2446. *
  2447. * Generate left vectors bidiagonalizing L in U
  2448. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
  2449. * (RWorkspace: 0)
  2450. *
  2451. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  2452. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2453. IRWORK = IE + M
  2454. *
  2455. * Perform bidiagonal QR iteration, computing left
  2456. * singular vectors of L in U, and computing right
  2457. * singular vectors of L in WORK(IR)
  2458. * (CWorkspace: need M*M)
  2459. * (RWorkspace: need BDSPAC)
  2460. *
  2461. CALL CBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
  2462. $ WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
  2463. $ RWORK( IRWORK ), INFO )
  2464. IU = ITAUQ
  2465. *
  2466. * Multiply right singular vectors of L in WORK(IR) by Q
  2467. * in A, storing result in WORK(IU) and copying to A
  2468. * (CWorkspace: need M*M+M, prefer M*M+M*N))
  2469. * (RWorkspace: 0)
  2470. *
  2471. DO 40 I = 1, N, CHUNK
  2472. BLK = MIN( N-I+1, CHUNK )
  2473. CALL CGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
  2474. $ LDWRKR, A( 1, I ), LDA, CZERO,
  2475. $ WORK( IU ), LDWRKU )
  2476. CALL CLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
  2477. $ A( 1, I ), LDA )
  2478. 40 CONTINUE
  2479. *
  2480. ELSE
  2481. *
  2482. * Insufficient workspace for a fast algorithm
  2483. *
  2484. ITAU = 1
  2485. IWORK = ITAU + M
  2486. *
  2487. * Compute A=L*Q
  2488. * (CWorkspace: need 2*M, prefer M+M*NB)
  2489. * (RWorkspace: 0)
  2490. *
  2491. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2492. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2493. *
  2494. * Copy L to U, zeroing out above it
  2495. *
  2496. CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
  2497. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
  2498. $ LDU )
  2499. *
  2500. * Generate Q in A
  2501. * (CWorkspace: need 2*M, prefer M+M*NB)
  2502. * (RWorkspace: 0)
  2503. *
  2504. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2505. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2506. IE = 1
  2507. ITAUQ = ITAU
  2508. ITAUP = ITAUQ + M
  2509. IWORK = ITAUP + M
  2510. *
  2511. * Bidiagonalize L in U
  2512. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  2513. * (RWorkspace: need M)
  2514. *
  2515. CALL CGEBRD( M, M, U, LDU, S, RWORK( IE ),
  2516. $ WORK( ITAUQ ), WORK( ITAUP ),
  2517. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2518. *
  2519. * Multiply right vectors bidiagonalizing L by Q in A
  2520. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  2521. * (RWorkspace: 0)
  2522. *
  2523. CALL CUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
  2524. $ WORK( ITAUP ), A, LDA, WORK( IWORK ),
  2525. $ LWORK-IWORK+1, IERR )
  2526. *
  2527. * Generate left vectors bidiagonalizing L in U
  2528. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  2529. * (RWorkspace: 0)
  2530. *
  2531. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  2532. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2533. IRWORK = IE + M
  2534. *
  2535. * Perform bidiagonal QR iteration, computing left
  2536. * singular vectors of A in U and computing right
  2537. * singular vectors of A in A
  2538. * (CWorkspace: 0)
  2539. * (RWorkspace: need BDSPAC)
  2540. *
  2541. CALL CBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
  2542. $ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
  2543. *
  2544. END IF
  2545. *
  2546. ELSE IF( WNTVS ) THEN
  2547. *
  2548. IF( WNTUN ) THEN
  2549. *
  2550. * Path 4t(N much larger than M, JOBU='N', JOBVT='S')
  2551. * M right singular vectors to be computed in VT and
  2552. * no left singular vectors to be computed
  2553. *
  2554. IF( LWORK.GE.M*M+3*M ) THEN
  2555. *
  2556. * Sufficient workspace for a fast algorithm
  2557. *
  2558. IR = 1
  2559. IF( LWORK.GE.WRKBL+LDA*M ) THEN
  2560. *
  2561. * WORK(IR) is LDA by M
  2562. *
  2563. LDWRKR = LDA
  2564. ELSE
  2565. *
  2566. * WORK(IR) is M by M
  2567. *
  2568. LDWRKR = M
  2569. END IF
  2570. ITAU = IR + LDWRKR*M
  2571. IWORK = ITAU + M
  2572. *
  2573. * Compute A=L*Q
  2574. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2575. * (RWorkspace: 0)
  2576. *
  2577. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2578. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2579. *
  2580. * Copy L to WORK(IR), zeroing out above it
  2581. *
  2582. CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ),
  2583. $ LDWRKR )
  2584. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2585. $ WORK( IR+LDWRKR ), LDWRKR )
  2586. *
  2587. * Generate Q in A
  2588. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2589. * (RWorkspace: 0)
  2590. *
  2591. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2592. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2593. IE = 1
  2594. ITAUQ = ITAU
  2595. ITAUP = ITAUQ + M
  2596. IWORK = ITAUP + M
  2597. *
  2598. * Bidiagonalize L in WORK(IR)
  2599. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  2600. * (RWorkspace: need M)
  2601. *
  2602. CALL CGEBRD( M, M, WORK( IR ), LDWRKR, S,
  2603. $ RWORK( IE ), WORK( ITAUQ ),
  2604. $ WORK( ITAUP ), WORK( IWORK ),
  2605. $ LWORK-IWORK+1, IERR )
  2606. *
  2607. * Generate right vectors bidiagonalizing L in
  2608. * WORK(IR)
  2609. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
  2610. * (RWorkspace: 0)
  2611. *
  2612. CALL CUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
  2613. $ WORK( ITAUP ), WORK( IWORK ),
  2614. $ LWORK-IWORK+1, IERR )
  2615. IRWORK = IE + M
  2616. *
  2617. * Perform bidiagonal QR iteration, computing right
  2618. * singular vectors of L in WORK(IR)
  2619. * (CWorkspace: need M*M)
  2620. * (RWorkspace: need BDSPAC)
  2621. *
  2622. CALL CBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
  2623. $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
  2624. $ RWORK( IRWORK ), INFO )
  2625. *
  2626. * Multiply right singular vectors of L in WORK(IR) by
  2627. * Q in A, storing result in VT
  2628. * (CWorkspace: need M*M)
  2629. * (RWorkspace: 0)
  2630. *
  2631. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
  2632. $ LDWRKR, A, LDA, CZERO, VT, LDVT )
  2633. *
  2634. ELSE
  2635. *
  2636. * Insufficient workspace for a fast algorithm
  2637. *
  2638. ITAU = 1
  2639. IWORK = ITAU + M
  2640. *
  2641. * Compute A=L*Q
  2642. * (CWorkspace: need 2*M, prefer M+M*NB)
  2643. * (RWorkspace: 0)
  2644. *
  2645. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2646. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2647. *
  2648. * Copy result to VT
  2649. *
  2650. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  2651. *
  2652. * Generate Q in VT
  2653. * (CWorkspace: need 2*M, prefer M+M*NB)
  2654. * (RWorkspace: 0)
  2655. *
  2656. CALL CUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
  2657. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2658. IE = 1
  2659. ITAUQ = ITAU
  2660. ITAUP = ITAUQ + M
  2661. IWORK = ITAUP + M
  2662. *
  2663. * Zero out above L in A
  2664. *
  2665. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2666. $ A( 1, 2 ), LDA )
  2667. *
  2668. * Bidiagonalize L in A
  2669. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  2670. * (RWorkspace: need M)
  2671. *
  2672. CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ),
  2673. $ WORK( ITAUQ ), WORK( ITAUP ),
  2674. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2675. *
  2676. * Multiply right vectors bidiagonalizing L by Q in VT
  2677. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  2678. * (RWorkspace: 0)
  2679. *
  2680. CALL CUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
  2681. $ WORK( ITAUP ), VT, LDVT,
  2682. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2683. IRWORK = IE + M
  2684. *
  2685. * Perform bidiagonal QR iteration, computing right
  2686. * singular vectors of A in VT
  2687. * (CWorkspace: 0)
  2688. * (RWorkspace: need BDSPAC)
  2689. *
  2690. CALL CBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
  2691. $ LDVT, CDUM, 1, CDUM, 1,
  2692. $ RWORK( IRWORK ), INFO )
  2693. *
  2694. END IF
  2695. *
  2696. ELSE IF( WNTUO ) THEN
  2697. *
  2698. * Path 5t(N much larger than M, JOBU='O', JOBVT='S')
  2699. * M right singular vectors to be computed in VT and
  2700. * M left singular vectors to be overwritten on A
  2701. *
  2702. IF( LWORK.GE.2*M*M+3*M ) THEN
  2703. *
  2704. * Sufficient workspace for a fast algorithm
  2705. *
  2706. IU = 1
  2707. IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
  2708. *
  2709. * WORK(IU) is LDA by M and WORK(IR) is LDA by M
  2710. *
  2711. LDWRKU = LDA
  2712. IR = IU + LDWRKU*M
  2713. LDWRKR = LDA
  2714. ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
  2715. *
  2716. * WORK(IU) is LDA by M and WORK(IR) is M by M
  2717. *
  2718. LDWRKU = LDA
  2719. IR = IU + LDWRKU*M
  2720. LDWRKR = M
  2721. ELSE
  2722. *
  2723. * WORK(IU) is M by M and WORK(IR) is M by M
  2724. *
  2725. LDWRKU = M
  2726. IR = IU + LDWRKU*M
  2727. LDWRKR = M
  2728. END IF
  2729. ITAU = IR + LDWRKR*M
  2730. IWORK = ITAU + M
  2731. *
  2732. * Compute A=L*Q
  2733. * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
  2734. * (RWorkspace: 0)
  2735. *
  2736. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2737. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2738. *
  2739. * Copy L to WORK(IU), zeroing out below it
  2740. *
  2741. CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
  2742. $ LDWRKU )
  2743. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2744. $ WORK( IU+LDWRKU ), LDWRKU )
  2745. *
  2746. * Generate Q in A
  2747. * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
  2748. * (RWorkspace: 0)
  2749. *
  2750. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2751. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2752. IE = 1
  2753. ITAUQ = ITAU
  2754. ITAUP = ITAUQ + M
  2755. IWORK = ITAUP + M
  2756. *
  2757. * Bidiagonalize L in WORK(IU), copying result to
  2758. * WORK(IR)
  2759. * (CWorkspace: need 2*M*M+3*M,
  2760. * prefer 2*M*M+2*M+2*M*NB)
  2761. * (RWorkspace: need M)
  2762. *
  2763. CALL CGEBRD( M, M, WORK( IU ), LDWRKU, S,
  2764. $ RWORK( IE ), WORK( ITAUQ ),
  2765. $ WORK( ITAUP ), WORK( IWORK ),
  2766. $ LWORK-IWORK+1, IERR )
  2767. CALL CLACPY( 'L', M, M, WORK( IU ), LDWRKU,
  2768. $ WORK( IR ), LDWRKR )
  2769. *
  2770. * Generate right bidiagonalizing vectors in WORK(IU)
  2771. * (CWorkspace: need 2*M*M+3*M-1,
  2772. * prefer 2*M*M+2*M+(M-1)*NB)
  2773. * (RWorkspace: 0)
  2774. *
  2775. CALL CUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
  2776. $ WORK( ITAUP ), WORK( IWORK ),
  2777. $ LWORK-IWORK+1, IERR )
  2778. *
  2779. * Generate left bidiagonalizing vectors in WORK(IR)
  2780. * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
  2781. * (RWorkspace: 0)
  2782. *
  2783. CALL CUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
  2784. $ WORK( ITAUQ ), WORK( IWORK ),
  2785. $ LWORK-IWORK+1, IERR )
  2786. IRWORK = IE + M
  2787. *
  2788. * Perform bidiagonal QR iteration, computing left
  2789. * singular vectors of L in WORK(IR) and computing
  2790. * right singular vectors of L in WORK(IU)
  2791. * (CWorkspace: need 2*M*M)
  2792. * (RWorkspace: need BDSPAC)
  2793. *
  2794. CALL CBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
  2795. $ WORK( IU ), LDWRKU, WORK( IR ),
  2796. $ LDWRKR, CDUM, 1, RWORK( IRWORK ),
  2797. $ INFO )
  2798. *
  2799. * Multiply right singular vectors of L in WORK(IU) by
  2800. * Q in A, storing result in VT
  2801. * (CWorkspace: need M*M)
  2802. * (RWorkspace: 0)
  2803. *
  2804. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
  2805. $ LDWRKU, A, LDA, CZERO, VT, LDVT )
  2806. *
  2807. * Copy left singular vectors of L to A
  2808. * (CWorkspace: need M*M)
  2809. * (RWorkspace: 0)
  2810. *
  2811. CALL CLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
  2812. $ LDA )
  2813. *
  2814. ELSE
  2815. *
  2816. * Insufficient workspace for a fast algorithm
  2817. *
  2818. ITAU = 1
  2819. IWORK = ITAU + M
  2820. *
  2821. * Compute A=L*Q, copying result to VT
  2822. * (CWorkspace: need 2*M, prefer M+M*NB)
  2823. * (RWorkspace: 0)
  2824. *
  2825. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2826. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2827. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  2828. *
  2829. * Generate Q in VT
  2830. * (CWorkspace: need 2*M, prefer M+M*NB)
  2831. * (RWorkspace: 0)
  2832. *
  2833. CALL CUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
  2834. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2835. IE = 1
  2836. ITAUQ = ITAU
  2837. ITAUP = ITAUQ + M
  2838. IWORK = ITAUP + M
  2839. *
  2840. * Zero out above L in A
  2841. *
  2842. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2843. $ A( 1, 2 ), LDA )
  2844. *
  2845. * Bidiagonalize L in A
  2846. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  2847. * (RWorkspace: need M)
  2848. *
  2849. CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ),
  2850. $ WORK( ITAUQ ), WORK( ITAUP ),
  2851. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2852. *
  2853. * Multiply right vectors bidiagonalizing L by Q in VT
  2854. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  2855. * (RWorkspace: 0)
  2856. *
  2857. CALL CUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
  2858. $ WORK( ITAUP ), VT, LDVT,
  2859. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2860. *
  2861. * Generate left bidiagonalizing vectors of L in A
  2862. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  2863. * (RWorkspace: 0)
  2864. *
  2865. CALL CUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
  2866. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2867. IRWORK = IE + M
  2868. *
  2869. * Perform bidiagonal QR iteration, computing left
  2870. * singular vectors of A in A and computing right
  2871. * singular vectors of A in VT
  2872. * (CWorkspace: 0)
  2873. * (RWorkspace: need BDSPAC)
  2874. *
  2875. CALL CBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
  2876. $ LDVT, A, LDA, CDUM, 1,
  2877. $ RWORK( IRWORK ), INFO )
  2878. *
  2879. END IF
  2880. *
  2881. ELSE IF( WNTUAS ) THEN
  2882. *
  2883. * Path 6t(N much larger than M, JOBU='S' or 'A',
  2884. * JOBVT='S')
  2885. * M right singular vectors to be computed in VT and
  2886. * M left singular vectors to be computed in U
  2887. *
  2888. IF( LWORK.GE.M*M+3*M ) THEN
  2889. *
  2890. * Sufficient workspace for a fast algorithm
  2891. *
  2892. IU = 1
  2893. IF( LWORK.GE.WRKBL+LDA*M ) THEN
  2894. *
  2895. * WORK(IU) is LDA by N
  2896. *
  2897. LDWRKU = LDA
  2898. ELSE
  2899. *
  2900. * WORK(IU) is LDA by M
  2901. *
  2902. LDWRKU = M
  2903. END IF
  2904. ITAU = IU + LDWRKU*M
  2905. IWORK = ITAU + M
  2906. *
  2907. * Compute A=L*Q
  2908. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2909. * (RWorkspace: 0)
  2910. *
  2911. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2912. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2913. *
  2914. * Copy L to WORK(IU), zeroing out above it
  2915. *
  2916. CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
  2917. $ LDWRKU )
  2918. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  2919. $ WORK( IU+LDWRKU ), LDWRKU )
  2920. *
  2921. * Generate Q in A
  2922. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  2923. * (RWorkspace: 0)
  2924. *
  2925. CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
  2926. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2927. IE = 1
  2928. ITAUQ = ITAU
  2929. ITAUP = ITAUQ + M
  2930. IWORK = ITAUP + M
  2931. *
  2932. * Bidiagonalize L in WORK(IU), copying result to U
  2933. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  2934. * (RWorkspace: need M)
  2935. *
  2936. CALL CGEBRD( M, M, WORK( IU ), LDWRKU, S,
  2937. $ RWORK( IE ), WORK( ITAUQ ),
  2938. $ WORK( ITAUP ), WORK( IWORK ),
  2939. $ LWORK-IWORK+1, IERR )
  2940. CALL CLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
  2941. $ LDU )
  2942. *
  2943. * Generate right bidiagonalizing vectors in WORK(IU)
  2944. * (CWorkspace: need M*M+3*M-1,
  2945. * prefer M*M+2*M+(M-1)*NB)
  2946. * (RWorkspace: 0)
  2947. *
  2948. CALL CUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
  2949. $ WORK( ITAUP ), WORK( IWORK ),
  2950. $ LWORK-IWORK+1, IERR )
  2951. *
  2952. * Generate left bidiagonalizing vectors in U
  2953. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
  2954. * (RWorkspace: 0)
  2955. *
  2956. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  2957. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2958. IRWORK = IE + M
  2959. *
  2960. * Perform bidiagonal QR iteration, computing left
  2961. * singular vectors of L in U and computing right
  2962. * singular vectors of L in WORK(IU)
  2963. * (CWorkspace: need M*M)
  2964. * (RWorkspace: need BDSPAC)
  2965. *
  2966. CALL CBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
  2967. $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
  2968. $ RWORK( IRWORK ), INFO )
  2969. *
  2970. * Multiply right singular vectors of L in WORK(IU) by
  2971. * Q in A, storing result in VT
  2972. * (CWorkspace: need M*M)
  2973. * (RWorkspace: 0)
  2974. *
  2975. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
  2976. $ LDWRKU, A, LDA, CZERO, VT, LDVT )
  2977. *
  2978. ELSE
  2979. *
  2980. * Insufficient workspace for a fast algorithm
  2981. *
  2982. ITAU = 1
  2983. IWORK = ITAU + M
  2984. *
  2985. * Compute A=L*Q, copying result to VT
  2986. * (CWorkspace: need 2*M, prefer M+M*NB)
  2987. * (RWorkspace: 0)
  2988. *
  2989. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  2990. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2991. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  2992. *
  2993. * Generate Q in VT
  2994. * (CWorkspace: need 2*M, prefer M+M*NB)
  2995. * (RWorkspace: 0)
  2996. *
  2997. CALL CUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
  2998. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  2999. *
  3000. * Copy L to U, zeroing out above it
  3001. *
  3002. CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
  3003. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3004. $ U( 1, 2 ), LDU )
  3005. IE = 1
  3006. ITAUQ = ITAU
  3007. ITAUP = ITAUQ + M
  3008. IWORK = ITAUP + M
  3009. *
  3010. * Bidiagonalize L in U
  3011. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  3012. * (RWorkspace: need M)
  3013. *
  3014. CALL CGEBRD( M, M, U, LDU, S, RWORK( IE ),
  3015. $ WORK( ITAUQ ), WORK( ITAUP ),
  3016. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3017. *
  3018. * Multiply right bidiagonalizing vectors in U by Q
  3019. * in VT
  3020. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  3021. * (RWorkspace: 0)
  3022. *
  3023. CALL CUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
  3024. $ WORK( ITAUP ), VT, LDVT,
  3025. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3026. *
  3027. * Generate left bidiagonalizing vectors in U
  3028. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  3029. * (RWorkspace: 0)
  3030. *
  3031. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  3032. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3033. IRWORK = IE + M
  3034. *
  3035. * Perform bidiagonal QR iteration, computing left
  3036. * singular vectors of A in U and computing right
  3037. * singular vectors of A in VT
  3038. * (CWorkspace: 0)
  3039. * (RWorkspace: need BDSPAC)
  3040. *
  3041. CALL CBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
  3042. $ LDVT, U, LDU, CDUM, 1,
  3043. $ RWORK( IRWORK ), INFO )
  3044. *
  3045. END IF
  3046. *
  3047. END IF
  3048. *
  3049. ELSE IF( WNTVA ) THEN
  3050. *
  3051. IF( WNTUN ) THEN
  3052. *
  3053. * Path 7t(N much larger than M, JOBU='N', JOBVT='A')
  3054. * N right singular vectors to be computed in VT and
  3055. * no left singular vectors to be computed
  3056. *
  3057. IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
  3058. *
  3059. * Sufficient workspace for a fast algorithm
  3060. *
  3061. IR = 1
  3062. IF( LWORK.GE.WRKBL+LDA*M ) THEN
  3063. *
  3064. * WORK(IR) is LDA by M
  3065. *
  3066. LDWRKR = LDA
  3067. ELSE
  3068. *
  3069. * WORK(IR) is M by M
  3070. *
  3071. LDWRKR = M
  3072. END IF
  3073. ITAU = IR + LDWRKR*M
  3074. IWORK = ITAU + M
  3075. *
  3076. * Compute A=L*Q, copying result to VT
  3077. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  3078. * (RWorkspace: 0)
  3079. *
  3080. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3081. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3082. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3083. *
  3084. * Copy L to WORK(IR), zeroing out above it
  3085. *
  3086. CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ),
  3087. $ LDWRKR )
  3088. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3089. $ WORK( IR+LDWRKR ), LDWRKR )
  3090. *
  3091. * Generate Q in VT
  3092. * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
  3093. * (RWorkspace: 0)
  3094. *
  3095. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3096. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3097. IE = 1
  3098. ITAUQ = ITAU
  3099. ITAUP = ITAUQ + M
  3100. IWORK = ITAUP + M
  3101. *
  3102. * Bidiagonalize L in WORK(IR)
  3103. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  3104. * (RWorkspace: need M)
  3105. *
  3106. CALL CGEBRD( M, M, WORK( IR ), LDWRKR, S,
  3107. $ RWORK( IE ), WORK( ITAUQ ),
  3108. $ WORK( ITAUP ), WORK( IWORK ),
  3109. $ LWORK-IWORK+1, IERR )
  3110. *
  3111. * Generate right bidiagonalizing vectors in WORK(IR)
  3112. * (CWorkspace: need M*M+3*M-1,
  3113. * prefer M*M+2*M+(M-1)*NB)
  3114. * (RWorkspace: 0)
  3115. *
  3116. CALL CUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
  3117. $ WORK( ITAUP ), WORK( IWORK ),
  3118. $ LWORK-IWORK+1, IERR )
  3119. IRWORK = IE + M
  3120. *
  3121. * Perform bidiagonal QR iteration, computing right
  3122. * singular vectors of L in WORK(IR)
  3123. * (CWorkspace: need M*M)
  3124. * (RWorkspace: need BDSPAC)
  3125. *
  3126. CALL CBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
  3127. $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
  3128. $ RWORK( IRWORK ), INFO )
  3129. *
  3130. * Multiply right singular vectors of L in WORK(IR) by
  3131. * Q in VT, storing result in A
  3132. * (CWorkspace: need M*M)
  3133. * (RWorkspace: 0)
  3134. *
  3135. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
  3136. $ LDWRKR, VT, LDVT, CZERO, A, LDA )
  3137. *
  3138. * Copy right singular vectors of A from A to VT
  3139. *
  3140. CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
  3141. *
  3142. ELSE
  3143. *
  3144. * Insufficient workspace for a fast algorithm
  3145. *
  3146. ITAU = 1
  3147. IWORK = ITAU + M
  3148. *
  3149. * Compute A=L*Q, copying result to VT
  3150. * (CWorkspace: need 2*M, prefer M+M*NB)
  3151. * (RWorkspace: 0)
  3152. *
  3153. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3154. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3155. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3156. *
  3157. * Generate Q in VT
  3158. * (CWorkspace: need M+N, prefer M+N*NB)
  3159. * (RWorkspace: 0)
  3160. *
  3161. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3162. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3163. IE = 1
  3164. ITAUQ = ITAU
  3165. ITAUP = ITAUQ + M
  3166. IWORK = ITAUP + M
  3167. *
  3168. * Zero out above L in A
  3169. *
  3170. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3171. $ A( 1, 2 ), LDA )
  3172. *
  3173. * Bidiagonalize L in A
  3174. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  3175. * (RWorkspace: need M)
  3176. *
  3177. CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ),
  3178. $ WORK( ITAUQ ), WORK( ITAUP ),
  3179. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3180. *
  3181. * Multiply right bidiagonalizing vectors in A by Q
  3182. * in VT
  3183. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  3184. * (RWorkspace: 0)
  3185. *
  3186. CALL CUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
  3187. $ WORK( ITAUP ), VT, LDVT,
  3188. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3189. IRWORK = IE + M
  3190. *
  3191. * Perform bidiagonal QR iteration, computing right
  3192. * singular vectors of A in VT
  3193. * (CWorkspace: 0)
  3194. * (RWorkspace: need BDSPAC)
  3195. *
  3196. CALL CBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
  3197. $ LDVT, CDUM, 1, CDUM, 1,
  3198. $ RWORK( IRWORK ), INFO )
  3199. *
  3200. END IF
  3201. *
  3202. ELSE IF( WNTUO ) THEN
  3203. *
  3204. * Path 8t(N much larger than M, JOBU='O', JOBVT='A')
  3205. * N right singular vectors to be computed in VT and
  3206. * M left singular vectors to be overwritten on A
  3207. *
  3208. IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
  3209. *
  3210. * Sufficient workspace for a fast algorithm
  3211. *
  3212. IU = 1
  3213. IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
  3214. *
  3215. * WORK(IU) is LDA by M and WORK(IR) is LDA by M
  3216. *
  3217. LDWRKU = LDA
  3218. IR = IU + LDWRKU*M
  3219. LDWRKR = LDA
  3220. ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
  3221. *
  3222. * WORK(IU) is LDA by M and WORK(IR) is M by M
  3223. *
  3224. LDWRKU = LDA
  3225. IR = IU + LDWRKU*M
  3226. LDWRKR = M
  3227. ELSE
  3228. *
  3229. * WORK(IU) is M by M and WORK(IR) is M by M
  3230. *
  3231. LDWRKU = M
  3232. IR = IU + LDWRKU*M
  3233. LDWRKR = M
  3234. END IF
  3235. ITAU = IR + LDWRKR*M
  3236. IWORK = ITAU + M
  3237. *
  3238. * Compute A=L*Q, copying result to VT
  3239. * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
  3240. * (RWorkspace: 0)
  3241. *
  3242. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3243. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3244. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3245. *
  3246. * Generate Q in VT
  3247. * (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
  3248. * (RWorkspace: 0)
  3249. *
  3250. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3251. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3252. *
  3253. * Copy L to WORK(IU), zeroing out above it
  3254. *
  3255. CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
  3256. $ LDWRKU )
  3257. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3258. $ WORK( IU+LDWRKU ), LDWRKU )
  3259. IE = 1
  3260. ITAUQ = ITAU
  3261. ITAUP = ITAUQ + M
  3262. IWORK = ITAUP + M
  3263. *
  3264. * Bidiagonalize L in WORK(IU), copying result to
  3265. * WORK(IR)
  3266. * (CWorkspace: need 2*M*M+3*M,
  3267. * prefer 2*M*M+2*M+2*M*NB)
  3268. * (RWorkspace: need M)
  3269. *
  3270. CALL CGEBRD( M, M, WORK( IU ), LDWRKU, S,
  3271. $ RWORK( IE ), WORK( ITAUQ ),
  3272. $ WORK( ITAUP ), WORK( IWORK ),
  3273. $ LWORK-IWORK+1, IERR )
  3274. CALL CLACPY( 'L', M, M, WORK( IU ), LDWRKU,
  3275. $ WORK( IR ), LDWRKR )
  3276. *
  3277. * Generate right bidiagonalizing vectors in WORK(IU)
  3278. * (CWorkspace: need 2*M*M+3*M-1,
  3279. * prefer 2*M*M+2*M+(M-1)*NB)
  3280. * (RWorkspace: 0)
  3281. *
  3282. CALL CUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
  3283. $ WORK( ITAUP ), WORK( IWORK ),
  3284. $ LWORK-IWORK+1, IERR )
  3285. *
  3286. * Generate left bidiagonalizing vectors in WORK(IR)
  3287. * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
  3288. * (RWorkspace: 0)
  3289. *
  3290. CALL CUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
  3291. $ WORK( ITAUQ ), WORK( IWORK ),
  3292. $ LWORK-IWORK+1, IERR )
  3293. IRWORK = IE + M
  3294. *
  3295. * Perform bidiagonal QR iteration, computing left
  3296. * singular vectors of L in WORK(IR) and computing
  3297. * right singular vectors of L in WORK(IU)
  3298. * (CWorkspace: need 2*M*M)
  3299. * (RWorkspace: need BDSPAC)
  3300. *
  3301. CALL CBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
  3302. $ WORK( IU ), LDWRKU, WORK( IR ),
  3303. $ LDWRKR, CDUM, 1, RWORK( IRWORK ),
  3304. $ INFO )
  3305. *
  3306. * Multiply right singular vectors of L in WORK(IU) by
  3307. * Q in VT, storing result in A
  3308. * (CWorkspace: need M*M)
  3309. * (RWorkspace: 0)
  3310. *
  3311. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
  3312. $ LDWRKU, VT, LDVT, CZERO, A, LDA )
  3313. *
  3314. * Copy right singular vectors of A from A to VT
  3315. *
  3316. CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
  3317. *
  3318. * Copy left singular vectors of A from WORK(IR) to A
  3319. *
  3320. CALL CLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
  3321. $ LDA )
  3322. *
  3323. ELSE
  3324. *
  3325. * Insufficient workspace for a fast algorithm
  3326. *
  3327. ITAU = 1
  3328. IWORK = ITAU + M
  3329. *
  3330. * Compute A=L*Q, copying result to VT
  3331. * (CWorkspace: need 2*M, prefer M+M*NB)
  3332. * (RWorkspace: 0)
  3333. *
  3334. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3335. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3336. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3337. *
  3338. * Generate Q in VT
  3339. * (CWorkspace: need M+N, prefer M+N*NB)
  3340. * (RWorkspace: 0)
  3341. *
  3342. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3343. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3344. IE = 1
  3345. ITAUQ = ITAU
  3346. ITAUP = ITAUQ + M
  3347. IWORK = ITAUP + M
  3348. *
  3349. * Zero out above L in A
  3350. *
  3351. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3352. $ A( 1, 2 ), LDA )
  3353. *
  3354. * Bidiagonalize L in A
  3355. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  3356. * (RWorkspace: need M)
  3357. *
  3358. CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ),
  3359. $ WORK( ITAUQ ), WORK( ITAUP ),
  3360. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3361. *
  3362. * Multiply right bidiagonalizing vectors in A by Q
  3363. * in VT
  3364. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  3365. * (RWorkspace: 0)
  3366. *
  3367. CALL CUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
  3368. $ WORK( ITAUP ), VT, LDVT,
  3369. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3370. *
  3371. * Generate left bidiagonalizing vectors in A
  3372. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  3373. * (RWorkspace: 0)
  3374. *
  3375. CALL CUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
  3376. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3377. IRWORK = IE + M
  3378. *
  3379. * Perform bidiagonal QR iteration, computing left
  3380. * singular vectors of A in A and computing right
  3381. * singular vectors of A in VT
  3382. * (CWorkspace: 0)
  3383. * (RWorkspace: need BDSPAC)
  3384. *
  3385. CALL CBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
  3386. $ LDVT, A, LDA, CDUM, 1,
  3387. $ RWORK( IRWORK ), INFO )
  3388. *
  3389. END IF
  3390. *
  3391. ELSE IF( WNTUAS ) THEN
  3392. *
  3393. * Path 9t(N much larger than M, JOBU='S' or 'A',
  3394. * JOBVT='A')
  3395. * N right singular vectors to be computed in VT and
  3396. * M left singular vectors to be computed in U
  3397. *
  3398. IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
  3399. *
  3400. * Sufficient workspace for a fast algorithm
  3401. *
  3402. IU = 1
  3403. IF( LWORK.GE.WRKBL+LDA*M ) THEN
  3404. *
  3405. * WORK(IU) is LDA by M
  3406. *
  3407. LDWRKU = LDA
  3408. ELSE
  3409. *
  3410. * WORK(IU) is M by M
  3411. *
  3412. LDWRKU = M
  3413. END IF
  3414. ITAU = IU + LDWRKU*M
  3415. IWORK = ITAU + M
  3416. *
  3417. * Compute A=L*Q, copying result to VT
  3418. * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
  3419. * (RWorkspace: 0)
  3420. *
  3421. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3422. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3423. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3424. *
  3425. * Generate Q in VT
  3426. * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
  3427. * (RWorkspace: 0)
  3428. *
  3429. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3430. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3431. *
  3432. * Copy L to WORK(IU), zeroing out above it
  3433. *
  3434. CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
  3435. $ LDWRKU )
  3436. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3437. $ WORK( IU+LDWRKU ), LDWRKU )
  3438. IE = 1
  3439. ITAUQ = ITAU
  3440. ITAUP = ITAUQ + M
  3441. IWORK = ITAUP + M
  3442. *
  3443. * Bidiagonalize L in WORK(IU), copying result to U
  3444. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
  3445. * (RWorkspace: need M)
  3446. *
  3447. CALL CGEBRD( M, M, WORK( IU ), LDWRKU, S,
  3448. $ RWORK( IE ), WORK( ITAUQ ),
  3449. $ WORK( ITAUP ), WORK( IWORK ),
  3450. $ LWORK-IWORK+1, IERR )
  3451. CALL CLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
  3452. $ LDU )
  3453. *
  3454. * Generate right bidiagonalizing vectors in WORK(IU)
  3455. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
  3456. * (RWorkspace: 0)
  3457. *
  3458. CALL CUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
  3459. $ WORK( ITAUP ), WORK( IWORK ),
  3460. $ LWORK-IWORK+1, IERR )
  3461. *
  3462. * Generate left bidiagonalizing vectors in U
  3463. * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
  3464. * (RWorkspace: 0)
  3465. *
  3466. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  3467. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3468. IRWORK = IE + M
  3469. *
  3470. * Perform bidiagonal QR iteration, computing left
  3471. * singular vectors of L in U and computing right
  3472. * singular vectors of L in WORK(IU)
  3473. * (CWorkspace: need M*M)
  3474. * (RWorkspace: need BDSPAC)
  3475. *
  3476. CALL CBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
  3477. $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
  3478. $ RWORK( IRWORK ), INFO )
  3479. *
  3480. * Multiply right singular vectors of L in WORK(IU) by
  3481. * Q in VT, storing result in A
  3482. * (CWorkspace: need M*M)
  3483. * (RWorkspace: 0)
  3484. *
  3485. CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
  3486. $ LDWRKU, VT, LDVT, CZERO, A, LDA )
  3487. *
  3488. * Copy right singular vectors of A from A to VT
  3489. *
  3490. CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
  3491. *
  3492. ELSE
  3493. *
  3494. * Insufficient workspace for a fast algorithm
  3495. *
  3496. ITAU = 1
  3497. IWORK = ITAU + M
  3498. *
  3499. * Compute A=L*Q, copying result to VT
  3500. * (CWorkspace: need 2*M, prefer M+M*NB)
  3501. * (RWorkspace: 0)
  3502. *
  3503. CALL CGELQF( M, N, A, LDA, WORK( ITAU ),
  3504. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3505. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3506. *
  3507. * Generate Q in VT
  3508. * (CWorkspace: need M+N, prefer M+N*NB)
  3509. * (RWorkspace: 0)
  3510. *
  3511. CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
  3512. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3513. *
  3514. * Copy L to U, zeroing out above it
  3515. *
  3516. CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
  3517. CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
  3518. $ U( 1, 2 ), LDU )
  3519. IE = 1
  3520. ITAUQ = ITAU
  3521. ITAUP = ITAUQ + M
  3522. IWORK = ITAUP + M
  3523. *
  3524. * Bidiagonalize L in U
  3525. * (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
  3526. * (RWorkspace: need M)
  3527. *
  3528. CALL CGEBRD( M, M, U, LDU, S, RWORK( IE ),
  3529. $ WORK( ITAUQ ), WORK( ITAUP ),
  3530. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3531. *
  3532. * Multiply right bidiagonalizing vectors in U by Q
  3533. * in VT
  3534. * (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
  3535. * (RWorkspace: 0)
  3536. *
  3537. CALL CUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
  3538. $ WORK( ITAUP ), VT, LDVT,
  3539. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3540. *
  3541. * Generate left bidiagonalizing vectors in U
  3542. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  3543. * (RWorkspace: 0)
  3544. *
  3545. CALL CUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
  3546. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3547. IRWORK = IE + M
  3548. *
  3549. * Perform bidiagonal QR iteration, computing left
  3550. * singular vectors of A in U and computing right
  3551. * singular vectors of A in VT
  3552. * (CWorkspace: 0)
  3553. * (RWorkspace: need BDSPAC)
  3554. *
  3555. CALL CBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
  3556. $ LDVT, U, LDU, CDUM, 1,
  3557. $ RWORK( IRWORK ), INFO )
  3558. *
  3559. END IF
  3560. *
  3561. END IF
  3562. *
  3563. END IF
  3564. *
  3565. ELSE
  3566. *
  3567. * N .LT. MNTHR
  3568. *
  3569. * Path 10t(N greater than M, but not much larger)
  3570. * Reduce to bidiagonal form without LQ decomposition
  3571. *
  3572. IE = 1
  3573. ITAUQ = 1
  3574. ITAUP = ITAUQ + M
  3575. IWORK = ITAUP + M
  3576. *
  3577. * Bidiagonalize A
  3578. * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
  3579. * (RWorkspace: M)
  3580. *
  3581. CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
  3582. $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
  3583. $ IERR )
  3584. IF( WNTUAS ) THEN
  3585. *
  3586. * If left singular vectors desired in U, copy result to U
  3587. * and generate left bidiagonalizing vectors in U
  3588. * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
  3589. * (RWorkspace: 0)
  3590. *
  3591. CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
  3592. CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
  3593. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3594. END IF
  3595. IF( WNTVAS ) THEN
  3596. *
  3597. * If right singular vectors desired in VT, copy result to
  3598. * VT and generate right bidiagonalizing vectors in VT
  3599. * (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
  3600. * (RWorkspace: 0)
  3601. *
  3602. CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
  3603. IF( WNTVA )
  3604. $ NRVT = N
  3605. IF( WNTVS )
  3606. $ NRVT = M
  3607. CALL CUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
  3608. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3609. END IF
  3610. IF( WNTUO ) THEN
  3611. *
  3612. * If left singular vectors desired in A, generate left
  3613. * bidiagonalizing vectors in A
  3614. * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
  3615. * (RWorkspace: 0)
  3616. *
  3617. CALL CUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
  3618. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3619. END IF
  3620. IF( WNTVO ) THEN
  3621. *
  3622. * If right singular vectors desired in A, generate right
  3623. * bidiagonalizing vectors in A
  3624. * (CWorkspace: need 3*M, prefer 2*M+M*NB)
  3625. * (RWorkspace: 0)
  3626. *
  3627. CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
  3628. $ WORK( IWORK ), LWORK-IWORK+1, IERR )
  3629. END IF
  3630. IRWORK = IE + M
  3631. IF( WNTUAS .OR. WNTUO )
  3632. $ NRU = M
  3633. IF( WNTUN )
  3634. $ NRU = 0
  3635. IF( WNTVAS .OR. WNTVO )
  3636. $ NCVT = N
  3637. IF( WNTVN )
  3638. $ NCVT = 0
  3639. IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
  3640. *
  3641. * Perform bidiagonal QR iteration, if desired, computing
  3642. * left singular vectors in U and computing right singular
  3643. * vectors in VT
  3644. * (CWorkspace: 0)
  3645. * (RWorkspace: need BDSPAC)
  3646. *
  3647. CALL CBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
  3648. $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
  3649. $ INFO )
  3650. ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
  3651. *
  3652. * Perform bidiagonal QR iteration, if desired, computing
  3653. * left singular vectors in U and computing right singular
  3654. * vectors in A
  3655. * (CWorkspace: 0)
  3656. * (RWorkspace: need BDSPAC)
  3657. *
  3658. CALL CBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
  3659. $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
  3660. $ INFO )
  3661. ELSE
  3662. *
  3663. * Perform bidiagonal QR iteration, if desired, computing
  3664. * left singular vectors in A and computing right singular
  3665. * vectors in VT
  3666. * (CWorkspace: 0)
  3667. * (RWorkspace: need BDSPAC)
  3668. *
  3669. CALL CBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
  3670. $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
  3671. $ INFO )
  3672. END IF
  3673. *
  3674. END IF
  3675. *
  3676. END IF
  3677. *
  3678. * Undo scaling if necessary
  3679. *
  3680. IF( ISCL.EQ.1 ) THEN
  3681. IF( ANRM.GT.BIGNUM )
  3682. $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
  3683. $ IERR )
  3684. IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
  3685. $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
  3686. $ RWORK( IE ), MINMN, IERR )
  3687. IF( ANRM.LT.SMLNUM )
  3688. $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
  3689. $ IERR )
  3690. IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
  3691. $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
  3692. $ RWORK( IE ), MINMN, IERR )
  3693. END IF
  3694. *
  3695. * Return optimal workspace in WORK(1)
  3696. *
  3697. WORK( 1 ) = MAXWRK
  3698. *
  3699. RETURN
  3700. *
  3701. * End of CGESVD
  3702. *
  3703. END