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

dgesvd.c 141 kB

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