You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

cgesvd.c 150 kB

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