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 142 kB

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