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.

sgesvd.f 135 kB

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