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.

zlatm5.c 30 kB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034
  1. #include <math.h>
  2. #include <stdlib.h>
  3. #include <string.h>
  4. #include <stdio.h>
  5. #include <complex.h>
  6. #ifdef complex
  7. #undef complex
  8. #endif
  9. #ifdef I
  10. #undef I
  11. #endif
  12. #if defined(_WIN64)
  13. typedef long long BLASLONG;
  14. typedef unsigned long long BLASULONG;
  15. #else
  16. typedef long BLASLONG;
  17. typedef unsigned long BLASULONG;
  18. #endif
  19. #ifdef LAPACK_ILP64
  20. typedef BLASLONG blasint;
  21. #if defined(_WIN64)
  22. #define blasabs(x) llabs(x)
  23. #else
  24. #define blasabs(x) labs(x)
  25. #endif
  26. #else
  27. typedef int blasint;
  28. #define blasabs(x) abs(x)
  29. #endif
  30. typedef blasint integer;
  31. typedef unsigned int uinteger;
  32. typedef char *address;
  33. typedef short int shortint;
  34. typedef float real;
  35. typedef double doublereal;
  36. typedef struct { real r, i; } complex;
  37. typedef struct { doublereal r, i; } doublecomplex;
  38. #ifdef _MSC_VER
  39. static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
  40. static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
  41. static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
  42. static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
  43. #else
  44. static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
  45. static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
  46. static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
  47. static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
  48. #endif
  49. #define pCf(z) (*_pCf(z))
  50. #define pCd(z) (*_pCd(z))
  51. typedef char integer1;
  52. #define TRUE_ (1)
  53. #define FALSE_ (0)
  54. /* Extern is for use with -E */
  55. #ifndef Extern
  56. #define Extern extern
  57. #endif
  58. /* I/O stuff */
  59. typedef int flag;
  60. typedef int ftnlen;
  61. typedef int ftnint;
  62. /*external read, write*/
  63. typedef struct
  64. { flag cierr;
  65. ftnint ciunit;
  66. flag ciend;
  67. char *cifmt;
  68. ftnint cirec;
  69. } cilist;
  70. /*internal read, write*/
  71. typedef struct
  72. { flag icierr;
  73. char *iciunit;
  74. flag iciend;
  75. char *icifmt;
  76. ftnint icirlen;
  77. ftnint icirnum;
  78. } icilist;
  79. /*open*/
  80. typedef struct
  81. { flag oerr;
  82. ftnint ounit;
  83. char *ofnm;
  84. ftnlen ofnmlen;
  85. char *osta;
  86. char *oacc;
  87. char *ofm;
  88. ftnint orl;
  89. char *oblnk;
  90. } olist;
  91. /*close*/
  92. typedef struct
  93. { flag cerr;
  94. ftnint cunit;
  95. char *csta;
  96. } cllist;
  97. /*rewind, backspace, endfile*/
  98. typedef struct
  99. { flag aerr;
  100. ftnint aunit;
  101. } alist;
  102. /* inquire */
  103. typedef struct
  104. { flag inerr;
  105. ftnint inunit;
  106. char *infile;
  107. ftnlen infilen;
  108. ftnint *inex; /*parameters in standard's order*/
  109. ftnint *inopen;
  110. ftnint *innum;
  111. ftnint *innamed;
  112. char *inname;
  113. ftnlen innamlen;
  114. char *inacc;
  115. ftnlen inacclen;
  116. char *inseq;
  117. ftnlen inseqlen;
  118. char *indir;
  119. ftnlen indirlen;
  120. char *infmt;
  121. ftnlen infmtlen;
  122. char *inform;
  123. ftnint informlen;
  124. char *inunf;
  125. ftnlen inunflen;
  126. ftnint *inrecl;
  127. ftnint *innrec;
  128. char *inblank;
  129. ftnlen inblanklen;
  130. } inlist;
  131. #define VOID void
  132. union Multitype { /* for multiple entry points */
  133. integer1 g;
  134. shortint h;
  135. integer i;
  136. /* longint j; */
  137. real r;
  138. doublereal d;
  139. complex c;
  140. doublecomplex z;
  141. };
  142. typedef union Multitype Multitype;
  143. struct Vardesc { /* for Namelist */
  144. char *name;
  145. char *addr;
  146. ftnlen *dims;
  147. int type;
  148. };
  149. typedef struct Vardesc Vardesc;
  150. struct Namelist {
  151. char *name;
  152. Vardesc **vars;
  153. int nvars;
  154. };
  155. typedef struct Namelist Namelist;
  156. #define abs(x) ((x) >= 0 ? (x) : -(x))
  157. #define dabs(x) (fabs(x))
  158. #define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
  159. #define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
  160. #define dmin(a,b) (f2cmin(a,b))
  161. #define dmax(a,b) (f2cmax(a,b))
  162. #define bit_test(a,b) ((a) >> (b) & 1)
  163. #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
  164. #define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
  165. #define abort_() { sig_die("Fortran abort routine called", 1); }
  166. #define c_abs(z) (cabsf(Cf(z)))
  167. #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
  168. #ifdef _MSC_VER
  169. #define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
  170. #define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
  171. #else
  172. #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
  173. #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
  174. #endif
  175. #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
  176. #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
  177. #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
  178. #define z_sin(R, Z) {pCd(R) = csin(Cd(Z));}
  179. //#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
  180. #define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
  181. #define d_abs(x) (fabs(*(x)))
  182. #define d_acos(x) (acos(*(x)))
  183. #define d_asin(x) (asin(*(x)))
  184. #define d_atan(x) (atan(*(x)))
  185. #define d_atn2(x, y) (atan2(*(x),*(y)))
  186. #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
  187. #define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
  188. #define d_cos(x) (cos(*(x)))
  189. #define d_cosh(x) (cosh(*(x)))
  190. #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
  191. #define d_exp(x) (exp(*(x)))
  192. #define d_imag(z) (cimag(Cd(z)))
  193. #define r_imag(z) (cimagf(Cf(z)))
  194. #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  195. #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  196. #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  197. #define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  198. #define d_log(x) (log(*(x)))
  199. #define d_mod(x, y) (fmod(*(x), *(y)))
  200. #define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
  201. #define d_nint(x) u_nint(*(x))
  202. #define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
  203. #define d_sign(a,b) u_sign(*(a),*(b))
  204. #define r_sign(a,b) u_sign(*(a),*(b))
  205. #define d_sin(x) (sin(*(x)))
  206. #define d_sinh(x) (sinh(*(x)))
  207. #define d_sqrt(x) (sqrt(*(x)))
  208. #define d_tan(x) (tan(*(x)))
  209. #define d_tanh(x) (tanh(*(x)))
  210. #define i_abs(x) abs(*(x))
  211. #define i_dnnt(x) ((integer)u_nint(*(x)))
  212. #define i_len(s, n) (n)
  213. #define i_nint(x) ((integer)u_nint(*(x)))
  214. #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
  215. #define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
  216. #define pow_si(B,E) spow_ui(*(B),*(E))
  217. #define pow_ri(B,E) spow_ui(*(B),*(E))
  218. #define pow_di(B,E) dpow_ui(*(B),*(E))
  219. #define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
  220. #define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
  221. #define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
  222. #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++ = ' '; }
  223. #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
  224. #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]; }
  225. #define sig_die(s, kill) { exit(1); }
  226. #define s_stop(s, n) {exit(0);}
  227. #define z_abs(z) (cabs(Cd(z)))
  228. #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
  229. #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
  230. #define myexit_() break;
  231. #define mycycle_() continue;
  232. #define myceiling_(w) {ceil(w)}
  233. #define myhuge_(w) {HUGE_VAL}
  234. //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
  235. #define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)}
  236. /* procedure parameter types for -A and -C++ */
  237. /* Table of constant values */
  238. static doublecomplex c_b1 = {1.,0.};
  239. static doublecomplex c_b3 = {0.,0.};
  240. static doublecomplex c_b5 = {20.,0.};
  241. /* > \brief \b ZLATM5 */
  242. /* =========== DOCUMENTATION =========== */
  243. /* Online html documentation available at */
  244. /* http://www.netlib.org/lapack/explore-html/ */
  245. /* Definition: */
  246. /* =========== */
  247. /* SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */
  248. /* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */
  249. /* QBLCKB ) */
  250. /* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */
  251. /* $ PRTYPE, QBLCKA, QBLCKB */
  252. /* DOUBLE PRECISION ALPHA */
  253. /* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), */
  254. /* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */
  255. /* $ L( LDL, * ), R( LDR, * ) */
  256. /* > \par Purpose: */
  257. /* ============= */
  258. /* > */
  259. /* > \verbatim */
  260. /* > */
  261. /* > ZLATM5 generates matrices involved in the Generalized Sylvester */
  262. /* > equation: */
  263. /* > */
  264. /* > A * R - L * B = C */
  265. /* > D * R - L * E = F */
  266. /* > */
  267. /* > They also satisfy (the diagonalization condition) */
  268. /* > */
  269. /* > [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */
  270. /* > [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */
  271. /* > */
  272. /* > \endverbatim */
  273. /* Arguments: */
  274. /* ========== */
  275. /* > \param[in] PRTYPE */
  276. /* > \verbatim */
  277. /* > PRTYPE is INTEGER */
  278. /* > "Points" to a certain type of the matrices to generate */
  279. /* > (see further details). */
  280. /* > \endverbatim */
  281. /* > */
  282. /* > \param[in] M */
  283. /* > \verbatim */
  284. /* > M is INTEGER */
  285. /* > Specifies the order of A and D and the number of rows in */
  286. /* > C, F, R and L. */
  287. /* > \endverbatim */
  288. /* > */
  289. /* > \param[in] N */
  290. /* > \verbatim */
  291. /* > N is INTEGER */
  292. /* > Specifies the order of B and E and the number of columns in */
  293. /* > C, F, R and L. */
  294. /* > \endverbatim */
  295. /* > */
  296. /* > \param[out] A */
  297. /* > \verbatim */
  298. /* > A is COMPLEX*16 array, dimension (LDA, M). */
  299. /* > On exit A M-by-M is initialized according to PRTYPE. */
  300. /* > \endverbatim */
  301. /* > */
  302. /* > \param[in] LDA */
  303. /* > \verbatim */
  304. /* > LDA is INTEGER */
  305. /* > The leading dimension of A. */
  306. /* > \endverbatim */
  307. /* > */
  308. /* > \param[out] B */
  309. /* > \verbatim */
  310. /* > B is COMPLEX*16 array, dimension (LDB, N). */
  311. /* > On exit B N-by-N is initialized according to PRTYPE. */
  312. /* > \endverbatim */
  313. /* > */
  314. /* > \param[in] LDB */
  315. /* > \verbatim */
  316. /* > LDB is INTEGER */
  317. /* > The leading dimension of B. */
  318. /* > \endverbatim */
  319. /* > */
  320. /* > \param[out] C */
  321. /* > \verbatim */
  322. /* > C is COMPLEX*16 array, dimension (LDC, N). */
  323. /* > On exit C M-by-N is initialized according to PRTYPE. */
  324. /* > \endverbatim */
  325. /* > */
  326. /* > \param[in] LDC */
  327. /* > \verbatim */
  328. /* > LDC is INTEGER */
  329. /* > The leading dimension of C. */
  330. /* > \endverbatim */
  331. /* > */
  332. /* > \param[out] D */
  333. /* > \verbatim */
  334. /* > D is COMPLEX*16 array, dimension (LDD, M). */
  335. /* > On exit D M-by-M is initialized according to PRTYPE. */
  336. /* > \endverbatim */
  337. /* > */
  338. /* > \param[in] LDD */
  339. /* > \verbatim */
  340. /* > LDD is INTEGER */
  341. /* > The leading dimension of D. */
  342. /* > \endverbatim */
  343. /* > */
  344. /* > \param[out] E */
  345. /* > \verbatim */
  346. /* > E is COMPLEX*16 array, dimension (LDE, N). */
  347. /* > On exit E N-by-N is initialized according to PRTYPE. */
  348. /* > \endverbatim */
  349. /* > */
  350. /* > \param[in] LDE */
  351. /* > \verbatim */
  352. /* > LDE is INTEGER */
  353. /* > The leading dimension of E. */
  354. /* > \endverbatim */
  355. /* > */
  356. /* > \param[out] F */
  357. /* > \verbatim */
  358. /* > F is COMPLEX*16 array, dimension (LDF, N). */
  359. /* > On exit F M-by-N is initialized according to PRTYPE. */
  360. /* > \endverbatim */
  361. /* > */
  362. /* > \param[in] LDF */
  363. /* > \verbatim */
  364. /* > LDF is INTEGER */
  365. /* > The leading dimension of F. */
  366. /* > \endverbatim */
  367. /* > */
  368. /* > \param[out] R */
  369. /* > \verbatim */
  370. /* > R is COMPLEX*16 array, dimension (LDR, N). */
  371. /* > On exit R M-by-N is initialized according to PRTYPE. */
  372. /* > \endverbatim */
  373. /* > */
  374. /* > \param[in] LDR */
  375. /* > \verbatim */
  376. /* > LDR is INTEGER */
  377. /* > The leading dimension of R. */
  378. /* > \endverbatim */
  379. /* > */
  380. /* > \param[out] L */
  381. /* > \verbatim */
  382. /* > L is COMPLEX*16 array, dimension (LDL, N). */
  383. /* > On exit L M-by-N is initialized according to PRTYPE. */
  384. /* > \endverbatim */
  385. /* > */
  386. /* > \param[in] LDL */
  387. /* > \verbatim */
  388. /* > LDL is INTEGER */
  389. /* > The leading dimension of L. */
  390. /* > \endverbatim */
  391. /* > */
  392. /* > \param[in] ALPHA */
  393. /* > \verbatim */
  394. /* > ALPHA is DOUBLE PRECISION */
  395. /* > Parameter used in generating PRTYPE = 1 and 5 matrices. */
  396. /* > \endverbatim */
  397. /* > */
  398. /* > \param[in] QBLCKA */
  399. /* > \verbatim */
  400. /* > QBLCKA is INTEGER */
  401. /* > When PRTYPE = 3, specifies the distance between 2-by-2 */
  402. /* > blocks on the diagonal in A. Otherwise, QBLCKA is not */
  403. /* > referenced. QBLCKA > 1. */
  404. /* > \endverbatim */
  405. /* > */
  406. /* > \param[in] QBLCKB */
  407. /* > \verbatim */
  408. /* > QBLCKB is INTEGER */
  409. /* > When PRTYPE = 3, specifies the distance between 2-by-2 */
  410. /* > blocks on the diagonal in B. Otherwise, QBLCKB is not */
  411. /* > referenced. QBLCKB > 1. */
  412. /* > \endverbatim */
  413. /* Authors: */
  414. /* ======== */
  415. /* > \author Univ. of Tennessee */
  416. /* > \author Univ. of California Berkeley */
  417. /* > \author Univ. of Colorado Denver */
  418. /* > \author NAG Ltd. */
  419. /* > \date June 2016 */
  420. /* > \ingroup complex16_matgen */
  421. /* > \par Further Details: */
  422. /* ===================== */
  423. /* > */
  424. /* > \verbatim */
  425. /* > */
  426. /* > PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
  427. /* > */
  428. /* > A : if (i == j) then A(i, j) = 1.0 */
  429. /* > if (j == i + 1) then A(i, j) = -1.0 */
  430. /* > else A(i, j) = 0.0, i, j = 1...M */
  431. /* > */
  432. /* > B : if (i == j) then B(i, j) = 1.0 - ALPHA */
  433. /* > if (j == i + 1) then B(i, j) = 1.0 */
  434. /* > else B(i, j) = 0.0, i, j = 1...N */
  435. /* > */
  436. /* > D : if (i == j) then D(i, j) = 1.0 */
  437. /* > else D(i, j) = 0.0, i, j = 1...M */
  438. /* > */
  439. /* > E : if (i == j) then E(i, j) = 1.0 */
  440. /* > else E(i, j) = 0.0, i, j = 1...N */
  441. /* > */
  442. /* > L = R are chosen from [-10...10], */
  443. /* > which specifies the right hand sides (C, F). */
  444. /* > */
  445. /* > PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
  446. /* > */
  447. /* > A : if (i <= j) then A(i, j) = [-1...1] */
  448. /* > else A(i, j) = 0.0, i, j = 1...M */
  449. /* > */
  450. /* > if (PRTYPE = 3) then */
  451. /* > A(k + 1, k + 1) = A(k, k) */
  452. /* > A(k + 1, k) = [-1...1] */
  453. /* > sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
  454. /* > k = 1, M - 1, QBLCKA */
  455. /* > */
  456. /* > B : if (i <= j) then B(i, j) = [-1...1] */
  457. /* > else B(i, j) = 0.0, i, j = 1...N */
  458. /* > */
  459. /* > if (PRTYPE = 3) then */
  460. /* > B(k + 1, k + 1) = B(k, k) */
  461. /* > B(k + 1, k) = [-1...1] */
  462. /* > sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
  463. /* > k = 1, N - 1, QBLCKB */
  464. /* > */
  465. /* > D : if (i <= j) then D(i, j) = [-1...1]. */
  466. /* > else D(i, j) = 0.0, i, j = 1...M */
  467. /* > */
  468. /* > */
  469. /* > E : if (i <= j) then D(i, j) = [-1...1] */
  470. /* > else E(i, j) = 0.0, i, j = 1...N */
  471. /* > */
  472. /* > L, R are chosen from [-10...10], */
  473. /* > which specifies the right hand sides (C, F). */
  474. /* > */
  475. /* > PRTYPE = 4 Full */
  476. /* > A(i, j) = [-10...10] */
  477. /* > D(i, j) = [-1...1] i,j = 1...M */
  478. /* > B(i, j) = [-10...10] */
  479. /* > E(i, j) = [-1...1] i,j = 1...N */
  480. /* > R(i, j) = [-10...10] */
  481. /* > L(i, j) = [-1...1] i = 1..M ,j = 1...N */
  482. /* > */
  483. /* > L, R specifies the right hand sides (C, F). */
  484. /* > */
  485. /* > PRTYPE = 5 special case common and/or close eigs. */
  486. /* > \endverbatim */
  487. /* > */
  488. /* ===================================================================== */
  489. /* Subroutine */ void zlatm5_(integer *prtype, integer *m, integer *n,
  490. doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
  491. doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
  492. doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
  493. doublecomplex *r__, integer *ldr, doublecomplex *l, integer *ldl,
  494. doublereal *alpha, integer *qblcka, integer *qblckb)
  495. {
  496. /* System generated locals */
  497. integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
  498. d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
  499. r_dim1, r_offset, i__1, i__2, i__3, i__4;
  500. doublereal d__1;
  501. doublecomplex z__1, z__2, z__3, z__4, z__5;
  502. /* Local variables */
  503. integer i__, j, k;
  504. doublecomplex imeps, reeps;
  505. extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *,
  506. integer *, doublecomplex *, doublecomplex *, integer *,
  507. doublecomplex *, integer *, doublecomplex *, doublecomplex *,
  508. integer *);
  509. /* -- LAPACK computational routine (version 3.7.0) -- */
  510. /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
  511. /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
  512. /* June 2016 */
  513. /* ===================================================================== */
  514. /* Parameter adjustments */
  515. a_dim1 = *lda;
  516. a_offset = 1 + a_dim1 * 1;
  517. a -= a_offset;
  518. b_dim1 = *ldb;
  519. b_offset = 1 + b_dim1 * 1;
  520. b -= b_offset;
  521. c_dim1 = *ldc;
  522. c_offset = 1 + c_dim1 * 1;
  523. c__ -= c_offset;
  524. d_dim1 = *ldd;
  525. d_offset = 1 + d_dim1 * 1;
  526. d__ -= d_offset;
  527. e_dim1 = *lde;
  528. e_offset = 1 + e_dim1 * 1;
  529. e -= e_offset;
  530. f_dim1 = *ldf;
  531. f_offset = 1 + f_dim1 * 1;
  532. f -= f_offset;
  533. r_dim1 = *ldr;
  534. r_offset = 1 + r_dim1 * 1;
  535. r__ -= r_offset;
  536. l_dim1 = *ldl;
  537. l_offset = 1 + l_dim1 * 1;
  538. l -= l_offset;
  539. /* Function Body */
  540. if (*prtype == 1) {
  541. i__1 = *m;
  542. for (i__ = 1; i__ <= i__1; ++i__) {
  543. i__2 = *m;
  544. for (j = 1; j <= i__2; ++j) {
  545. if (i__ == j) {
  546. i__3 = i__ + j * a_dim1;
  547. a[i__3].r = 1., a[i__3].i = 0.;
  548. i__3 = i__ + j * d_dim1;
  549. d__[i__3].r = 1., d__[i__3].i = 0.;
  550. } else if (i__ == j - 1) {
  551. i__3 = i__ + j * a_dim1;
  552. z__1.r = -1., z__1.i = 0.;
  553. a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  554. i__3 = i__ + j * d_dim1;
  555. d__[i__3].r = 0., d__[i__3].i = 0.;
  556. } else {
  557. i__3 = i__ + j * a_dim1;
  558. a[i__3].r = 0., a[i__3].i = 0.;
  559. i__3 = i__ + j * d_dim1;
  560. d__[i__3].r = 0., d__[i__3].i = 0.;
  561. }
  562. /* L10: */
  563. }
  564. /* L20: */
  565. }
  566. i__1 = *n;
  567. for (i__ = 1; i__ <= i__1; ++i__) {
  568. i__2 = *n;
  569. for (j = 1; j <= i__2; ++j) {
  570. if (i__ == j) {
  571. i__3 = i__ + j * b_dim1;
  572. z__1.r = 1. - *alpha, z__1.i = 0.;
  573. b[i__3].r = z__1.r, b[i__3].i = z__1.i;
  574. i__3 = i__ + j * e_dim1;
  575. e[i__3].r = 1., e[i__3].i = 0.;
  576. } else if (i__ == j - 1) {
  577. i__3 = i__ + j * b_dim1;
  578. b[i__3].r = 1., b[i__3].i = 0.;
  579. i__3 = i__ + j * e_dim1;
  580. e[i__3].r = 0., e[i__3].i = 0.;
  581. } else {
  582. i__3 = i__ + j * b_dim1;
  583. b[i__3].r = 0., b[i__3].i = 0.;
  584. i__3 = i__ + j * e_dim1;
  585. e[i__3].r = 0., e[i__3].i = 0.;
  586. }
  587. /* L30: */
  588. }
  589. /* L40: */
  590. }
  591. i__1 = *m;
  592. for (i__ = 1; i__ <= i__1; ++i__) {
  593. i__2 = *n;
  594. for (j = 1; j <= i__2; ++j) {
  595. i__3 = i__ + j * r_dim1;
  596. i__4 = i__ / j;
  597. z__4.r = (doublereal) i__4, z__4.i = 0.;
  598. z_sin(&z__3, &z__4);
  599. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  600. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  601. z__2.i * 20.;
  602. r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
  603. i__3 = i__ + j * l_dim1;
  604. i__4 = i__ + j * r_dim1;
  605. l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i;
  606. /* L50: */
  607. }
  608. /* L60: */
  609. }
  610. } else if (*prtype == 2 || *prtype == 3) {
  611. i__1 = *m;
  612. for (i__ = 1; i__ <= i__1; ++i__) {
  613. i__2 = *m;
  614. for (j = 1; j <= i__2; ++j) {
  615. if (i__ <= j) {
  616. i__3 = i__ + j * a_dim1;
  617. z__4.r = (doublereal) i__, z__4.i = 0.;
  618. z_sin(&z__3, &z__4);
  619. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  620. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
  621. + z__2.i * 2.;
  622. a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  623. i__3 = i__ + j * d_dim1;
  624. i__4 = i__ * j;
  625. z__4.r = (doublereal) i__4, z__4.i = 0.;
  626. z_sin(&z__3, &z__4);
  627. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  628. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
  629. + z__2.i * 2.;
  630. d__[i__3].r = z__1.r, d__[i__3].i = z__1.i;
  631. } else {
  632. i__3 = i__ + j * a_dim1;
  633. a[i__3].r = 0., a[i__3].i = 0.;
  634. i__3 = i__ + j * d_dim1;
  635. d__[i__3].r = 0., d__[i__3].i = 0.;
  636. }
  637. /* L70: */
  638. }
  639. /* L80: */
  640. }
  641. i__1 = *n;
  642. for (i__ = 1; i__ <= i__1; ++i__) {
  643. i__2 = *n;
  644. for (j = 1; j <= i__2; ++j) {
  645. if (i__ <= j) {
  646. i__3 = i__ + j * b_dim1;
  647. i__4 = i__ + j;
  648. z__4.r = (doublereal) i__4, z__4.i = 0.;
  649. z_sin(&z__3, &z__4);
  650. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  651. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
  652. + z__2.i * 2.;
  653. b[i__3].r = z__1.r, b[i__3].i = z__1.i;
  654. i__3 = i__ + j * e_dim1;
  655. z__4.r = (doublereal) j, z__4.i = 0.;
  656. z_sin(&z__3, &z__4);
  657. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  658. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
  659. + z__2.i * 2.;
  660. e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  661. } else {
  662. i__3 = i__ + j * b_dim1;
  663. b[i__3].r = 0., b[i__3].i = 0.;
  664. i__3 = i__ + j * e_dim1;
  665. e[i__3].r = 0., e[i__3].i = 0.;
  666. }
  667. /* L90: */
  668. }
  669. /* L100: */
  670. }
  671. i__1 = *m;
  672. for (i__ = 1; i__ <= i__1; ++i__) {
  673. i__2 = *n;
  674. for (j = 1; j <= i__2; ++j) {
  675. i__3 = i__ + j * r_dim1;
  676. i__4 = i__ * j;
  677. z__4.r = (doublereal) i__4, z__4.i = 0.;
  678. z_sin(&z__3, &z__4);
  679. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  680. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  681. z__2.i * 20.;
  682. r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
  683. i__3 = i__ + j * l_dim1;
  684. i__4 = i__ + j;
  685. z__4.r = (doublereal) i__4, z__4.i = 0.;
  686. z_sin(&z__3, &z__4);
  687. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  688. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  689. z__2.i * 20.;
  690. l[i__3].r = z__1.r, l[i__3].i = z__1.i;
  691. /* L110: */
  692. }
  693. /* L120: */
  694. }
  695. if (*prtype == 3) {
  696. if (*qblcka <= 1) {
  697. *qblcka = 2;
  698. }
  699. i__1 = *m - 1;
  700. i__2 = *qblcka;
  701. for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
  702. i__3 = k + 1 + (k + 1) * a_dim1;
  703. i__4 = k + k * a_dim1;
  704. a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
  705. i__3 = k + 1 + k * a_dim1;
  706. z_sin(&z__2, &a[k + (k + 1) * a_dim1]);
  707. z__1.r = -z__2.r, z__1.i = -z__2.i;
  708. a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  709. /* L130: */
  710. }
  711. if (*qblckb <= 1) {
  712. *qblckb = 2;
  713. }
  714. i__2 = *n - 1;
  715. i__1 = *qblckb;
  716. for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
  717. i__3 = k + 1 + (k + 1) * b_dim1;
  718. i__4 = k + k * b_dim1;
  719. b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
  720. i__3 = k + 1 + k * b_dim1;
  721. z_sin(&z__2, &b[k + (k + 1) * b_dim1]);
  722. z__1.r = -z__2.r, z__1.i = -z__2.i;
  723. b[i__3].r = z__1.r, b[i__3].i = z__1.i;
  724. /* L140: */
  725. }
  726. }
  727. } else if (*prtype == 4) {
  728. i__1 = *m;
  729. for (i__ = 1; i__ <= i__1; ++i__) {
  730. i__2 = *m;
  731. for (j = 1; j <= i__2; ++j) {
  732. i__3 = i__ + j * a_dim1;
  733. i__4 = i__ * j;
  734. z__4.r = (doublereal) i__4, z__4.i = 0.;
  735. z_sin(&z__3, &z__4);
  736. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  737. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  738. z__2.i * 20.;
  739. a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  740. i__3 = i__ + j * d_dim1;
  741. i__4 = i__ + j;
  742. z__4.r = (doublereal) i__4, z__4.i = 0.;
  743. z_sin(&z__3, &z__4);
  744. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  745. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
  746. z__2.i * 2.;
  747. d__[i__3].r = z__1.r, d__[i__3].i = z__1.i;
  748. /* L150: */
  749. }
  750. /* L160: */
  751. }
  752. i__1 = *n;
  753. for (i__ = 1; i__ <= i__1; ++i__) {
  754. i__2 = *n;
  755. for (j = 1; j <= i__2; ++j) {
  756. i__3 = i__ + j * b_dim1;
  757. i__4 = i__ + j;
  758. z__4.r = (doublereal) i__4, z__4.i = 0.;
  759. z_sin(&z__3, &z__4);
  760. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  761. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  762. z__2.i * 20.;
  763. b[i__3].r = z__1.r, b[i__3].i = z__1.i;
  764. i__3 = i__ + j * e_dim1;
  765. i__4 = i__ * j;
  766. z__4.r = (doublereal) i__4, z__4.i = 0.;
  767. z_sin(&z__3, &z__4);
  768. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  769. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
  770. z__2.i * 2.;
  771. e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  772. /* L170: */
  773. }
  774. /* L180: */
  775. }
  776. i__1 = *m;
  777. for (i__ = 1; i__ <= i__1; ++i__) {
  778. i__2 = *n;
  779. for (j = 1; j <= i__2; ++j) {
  780. i__3 = i__ + j * r_dim1;
  781. i__4 = j / i__;
  782. z__4.r = (doublereal) i__4, z__4.i = 0.;
  783. z_sin(&z__3, &z__4);
  784. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  785. z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
  786. z__2.i * 20.;
  787. r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
  788. i__3 = i__ + j * l_dim1;
  789. i__4 = i__ * j;
  790. z__4.r = (doublereal) i__4, z__4.i = 0.;
  791. z_sin(&z__3, &z__4);
  792. z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
  793. z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
  794. z__2.i * 2.;
  795. l[i__3].r = z__1.r, l[i__3].i = z__1.i;
  796. /* L190: */
  797. }
  798. /* L200: */
  799. }
  800. } else if (*prtype >= 5) {
  801. z__3.r = 1., z__3.i = 0.;
  802. z__2.r = z__3.r * 20. - z__3.i * 0., z__2.i = z__3.r * 0. + z__3.i *
  803. 20.;
  804. z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha;
  805. reeps.r = z__1.r, reeps.i = z__1.i;
  806. z__2.r = -1.5, z__2.i = 0.;
  807. z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha;
  808. imeps.r = z__1.r, imeps.i = z__1.i;
  809. i__1 = *m;
  810. for (i__ = 1; i__ <= i__1; ++i__) {
  811. i__2 = *n;
  812. for (j = 1; j <= i__2; ++j) {
  813. i__3 = i__ + j * r_dim1;
  814. i__4 = i__ * j;
  815. z__5.r = (doublereal) i__4, z__5.i = 0.;
  816. z_sin(&z__4, &z__5);
  817. z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i;
  818. z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i;
  819. z_div(&z__1, &z__2, &c_b5);
  820. r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
  821. i__3 = i__ + j * l_dim1;
  822. i__4 = i__ + j;
  823. z__5.r = (doublereal) i__4, z__5.i = 0.;
  824. z_sin(&z__4, &z__5);
  825. z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i;
  826. z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i;
  827. z_div(&z__1, &z__2, &c_b5);
  828. l[i__3].r = z__1.r, l[i__3].i = z__1.i;
  829. /* L210: */
  830. }
  831. /* L220: */
  832. }
  833. i__1 = *m;
  834. for (i__ = 1; i__ <= i__1; ++i__) {
  835. i__2 = i__ + i__ * d_dim1;
  836. d__[i__2].r = 1., d__[i__2].i = 0.;
  837. /* L230: */
  838. }
  839. i__1 = *m;
  840. for (i__ = 1; i__ <= i__1; ++i__) {
  841. if (i__ <= 4) {
  842. i__2 = i__ + i__ * a_dim1;
  843. a[i__2].r = 1., a[i__2].i = 0.;
  844. if (i__ > 2) {
  845. i__2 = i__ + i__ * a_dim1;
  846. z__1.r = reeps.r + 1., z__1.i = reeps.i + 0.;
  847. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  848. }
  849. if (i__ % 2 != 0 && i__ < *m) {
  850. i__2 = i__ + (i__ + 1) * a_dim1;
  851. a[i__2].r = imeps.r, a[i__2].i = imeps.i;
  852. } else if (i__ > 1) {
  853. i__2 = i__ + (i__ - 1) * a_dim1;
  854. z__1.r = -imeps.r, z__1.i = -imeps.i;
  855. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  856. }
  857. } else if (i__ <= 8) {
  858. if (i__ <= 6) {
  859. i__2 = i__ + i__ * a_dim1;
  860. a[i__2].r = reeps.r, a[i__2].i = reeps.i;
  861. } else {
  862. i__2 = i__ + i__ * a_dim1;
  863. z__1.r = -reeps.r, z__1.i = -reeps.i;
  864. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  865. }
  866. if (i__ % 2 != 0 && i__ < *m) {
  867. i__2 = i__ + (i__ + 1) * a_dim1;
  868. a[i__2].r = 1., a[i__2].i = 0.;
  869. } else if (i__ > 1) {
  870. i__2 = i__ + (i__ - 1) * a_dim1;
  871. z__1.r = -1., z__1.i = 0.;
  872. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  873. }
  874. } else {
  875. i__2 = i__ + i__ * a_dim1;
  876. a[i__2].r = 1., a[i__2].i = 0.;
  877. if (i__ % 2 != 0 && i__ < *m) {
  878. i__2 = i__ + (i__ + 1) * a_dim1;
  879. d__1 = 2.;
  880. z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i;
  881. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  882. } else if (i__ > 1) {
  883. i__2 = i__ + (i__ - 1) * a_dim1;
  884. z__2.r = -imeps.r, z__2.i = -imeps.i;
  885. d__1 = 2.;
  886. z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  887. a[i__2].r = z__1.r, a[i__2].i = z__1.i;
  888. }
  889. }
  890. /* L240: */
  891. }
  892. i__1 = *n;
  893. for (i__ = 1; i__ <= i__1; ++i__) {
  894. i__2 = i__ + i__ * e_dim1;
  895. e[i__2].r = 1., e[i__2].i = 0.;
  896. if (i__ <= 4) {
  897. i__2 = i__ + i__ * b_dim1;
  898. z__1.r = -1., z__1.i = 0.;
  899. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  900. if (i__ > 2) {
  901. i__2 = i__ + i__ * b_dim1;
  902. z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i;
  903. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  904. }
  905. if (i__ % 2 != 0 && i__ < *n) {
  906. i__2 = i__ + (i__ + 1) * b_dim1;
  907. b[i__2].r = imeps.r, b[i__2].i = imeps.i;
  908. } else if (i__ > 1) {
  909. i__2 = i__ + (i__ - 1) * b_dim1;
  910. z__1.r = -imeps.r, z__1.i = -imeps.i;
  911. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  912. }
  913. } else if (i__ <= 8) {
  914. if (i__ <= 6) {
  915. i__2 = i__ + i__ * b_dim1;
  916. b[i__2].r = reeps.r, b[i__2].i = reeps.i;
  917. } else {
  918. i__2 = i__ + i__ * b_dim1;
  919. z__1.r = -reeps.r, z__1.i = -reeps.i;
  920. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  921. }
  922. if (i__ % 2 != 0 && i__ < *n) {
  923. i__2 = i__ + (i__ + 1) * b_dim1;
  924. z__1.r = imeps.r + 1., z__1.i = imeps.i + 0.;
  925. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  926. } else if (i__ > 1) {
  927. i__2 = i__ + (i__ - 1) * b_dim1;
  928. z__2.r = -1., z__2.i = 0.;
  929. z__1.r = z__2.r - imeps.r, z__1.i = z__2.i - imeps.i;
  930. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  931. }
  932. } else {
  933. i__2 = i__ + i__ * b_dim1;
  934. z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i;
  935. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  936. if (i__ % 2 != 0 && i__ < *n) {
  937. i__2 = i__ + (i__ + 1) * b_dim1;
  938. d__1 = 2.;
  939. z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i;
  940. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  941. } else if (i__ > 1) {
  942. i__2 = i__ + (i__ - 1) * b_dim1;
  943. z__2.r = -imeps.r, z__2.i = -imeps.i;
  944. d__1 = 2.;
  945. z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  946. b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  947. }
  948. }
  949. /* L250: */
  950. }
  951. }
  952. /* Compute rhs (C, F) */
  953. zgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, &
  954. c_b3, &c__[c_offset], ldc);
  955. z__1.r = -1., z__1.i = 0.;
  956. zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &b[b_offset], ldb, &
  957. c_b1, &c__[c_offset], ldc);
  958. zgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr,
  959. &c_b3, &f[f_offset], ldf);
  960. z__1.r = -1., z__1.i = 0.;
  961. zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &e[e_offset], lde, &
  962. c_b1, &f[f_offset], ldf);
  963. /* End of ZLATM5 */
  964. return;
  965. } /* zlatm5_ */