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