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.

dgesvd.c 144 kB

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