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.c 136 kB

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