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.

zgesvd.c 150 kB

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